never executed always true always false
1 {-# LANGUAGE DeriveTraversable #-}
2 module HelVM.HelIO.Collections.MapList where
3
4 import qualified HelVM.HelIO.Containers.LLIndexSafe as LL
5 import qualified HelVM.HelIO.Containers.LLInsertDef as LL
6
7 import qualified HelVM.HelIO.Containers.MTIndexSafe as MT
8 import qualified HelVM.HelIO.Containers.MTInsertDef as MT
9
10 import HelVM.HelIO.Control.Safe
11
12 import Control.Monad.Extra
13
14 import Data.Default
15 import Data.Sequences (IsSequence (..), SemiSequence (..))
16
17 import qualified Data.IntMap as IntMap
18 import qualified Data.List.Index as List
19 import qualified Data.ListLike as LL
20 import qualified Data.MonoTraversable as MT
21 import qualified Data.Sequences as S
22
23 import qualified GHC.Exts as I (IsList (..))
24 import qualified Text.Show
25
26 -- | Construction
27 mapListEmpty :: MapList a
28 mapListEmpty = mapListFromList []
29
30 mapListFromList :: [a] -> MapList a
31 mapListFromList = fromIndexedList <$> List.indexed
32
33 fromIndexedList :: IndexedList a -> MapList a
34 fromIndexedList = fromIntMap <$> IntMap.fromList
35
36 fromIntMap :: IntMap a -> MapList a
37 fromIntMap = MapList
38
39 -- | DeConstruction
40 mapListToList :: Default a => MapList a -> [a]
41 mapListToList = listFromDescList <$> toDescList
42
43 toDescList :: MapList a -> IndexedList a
44 toDescList = IntMap.toDescList <$> unMapList
45
46 -- | Internal function
47 listFromDescList :: Default a => IndexedList a -> [a]
48 listFromDescList = loop act <$> ([] , ) where
49 act :: Default a => AccWithIndexedList a -> Either (AccWithIndexedList a) [a]
50 act (acc , [] ) = Right acc
51 act (acc , [(i , v)] ) = Right $ consDef i $ v : acc
52 act (acc , (i1 , v1) : (i2 , v2) : l ) = Left (consDef (i1 - i2 - 1) $ v1 : acc , (i2 , v2) : l)
53
54 consDef :: Default a => Key -> [a] -> [a]
55 consDef i l = (check <$> compare i) 0 where
56 check LT = error "MapList.consDef index is negative"
57 check EQ = l
58 check GT = consDef (i - 1) (def : l)
59
60 -- | Types
61 type AccWithIndexedList a = ([a] , IndexedList a)
62 type Key = IntMap.Key
63 type IndexedList a = [(Key , a)]
64 type MapString = MapList Char
65
66 newtype MapList a = MapList {unMapList :: IntMap a}
67 deriving stock (Eq , Ord, Read)
68 deriving stock (Foldable , Functor , Traversable)
69 deriving newtype (Semigroup , Monoid)
70
71 -- | Standard instances
72 instance (Default a , Show a) => Show (MapList a) where
73 show = show <$> I.toList
74
75 instance IsString MapString where
76 fromString = mapListFromList
77
78 instance Default a => IsList (MapList a) where
79 type (Item (MapList a)) = a
80 toList = mapListToList
81 fromList = mapListFromList
82 fromListN n = mapListFromList <$> fromListN n
83
84 -- | MonoTraversable instances
85 type instance MT.Element (MapList a) = a
86
87 instance MT.MonoFoldable (MapList a) where
88
89 instance MT.MonoFunctor (MapList a) where
90
91 instance MT.MonoTraversable (MapList a) where
92
93 instance MT.GrowingAppend (MapList a) where
94
95 instance MT.MonoPointed (MapList a) where
96 opoint = mapListFromList . pure
97
98 instance S.SemiSequence (MapList a) where
99 type Index (MapList a) = Int
100 cons e = fromIntMap . IntMap.insert 0 e . IntMap.mapKeysMonotonic (+ 1) . unMapList
101 snoc l e = fromIntMap $ IntMap.insert (nextKey l) e (unMapList l)
102 reverse l = fromIntMap $ IntMap.mapKeys (largestKey l -) (unMapList l)
103 sortBy f l = fromIntMap $ IntMap.fromDistinctAscList $ zip (IntMap.keys m) (Prelude.sortBy f $ IntMap.elems m) where m = unMapList l
104 intersperse e = mapListFromList . Prelude.intersperse e . IntMap.elems . unMapList
105 find f = Prelude.find f . IntMap.elems . unMapList
106
107 instance S.IsSequence (MapList a) where
108 tailEx = mapListTail
109 initEx = fromIntMap . IntMap.deleteMax . unMapList
110 replicate n = mapListFromList . Prelude.replicate n
111 uncons l = (, mapListTail l) <$> mapListFindMaybe 0 l
112
113 -- | ListLike instances
114 instance LL.FoldableLL (MapList a) a where
115 foldl f b = IntMap.foldl f b <$> unMapList
116 foldr f b = IntMap.foldr f b <$> unMapList
117
118 -- | My instances
119 instance {-# OVERLAPPING #-} LL.IndexSafe (MapList a) a where
120 findWithDefault e i = IntMap.findWithDefault e i <$> unMapList
121 findMaybe = mapListFindMaybe
122 indexMaybe = mapListIndexMaybe
123 findSafe i = liftMaybeOrError "MapList.findSafe: index is not correct" <$> mapListFindMaybe i
124 indexSafe l = liftMaybeOrError "MapList.LLIndexSafe: index is not correct" <$> mapListIndexMaybe l
125
126 instance {-# OVERLAPPING #-} MT.IndexSafe (MapList a) where
127 findWithDefault e i = IntMap.findWithDefault e i <$> unMapList
128 findMaybe = mapListFindMaybe
129 indexMaybe = mapListIndexMaybe
130 findSafe i = liftMaybeOrError "MapList.findSafe: index is not correct" <$> mapListFindMaybe i
131 indexSafe l = liftMaybeOrError "MapList.MTIndexSafe: index is not correct" <$> mapListIndexMaybe l
132
133 instance LL.InsertDef (MapList a) a where
134 insertDef i e = fromIntMap . IntMap.insert i e <$> unMapList
135
136 instance MT.InsertDef (MapList a) where
137 insertDef i e = fromIntMap . IntMap.insert i e <$> unMapList
138
139 -- | Internal functions
140 mapListFindMaybe :: Key -> MapList a -> Maybe a
141 mapListFindMaybe i = IntMap.lookup i <$> unMapList
142
143 mapListIndexMaybe :: MapList a -> Key -> Maybe a
144 mapListIndexMaybe l i = unMapList l IntMap.!? i
145
146 nextKey :: MapList a -> Key
147 nextKey = maybe 0 ((+ 1) . fst) . IntMap.lookupMax . unMapList
148
149 largestKey :: MapList a -> Key
150 largestKey = maybe 0 fst . IntMap.lookupMax . unMapList
151
152 mapListTail :: MapList a -> MapList a
153 mapListTail = fromIntMap . IntMap.mapKeysMonotonic (subtract 1) . IntMap.delete 0 . unMapList