never executed always true always false
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1993-1998
4
5
6 -}
7 {-# LANGUAGE DeriveFunctor #-}
8 {-# LANGUAGE BangPatterns #-}
9 {-# LANGUAGE ViewPatterns #-}
10 {-# LANGUAGE PatternSynonyms #-}
11 {-# LANGUAGE UnboxedSums #-}
12 {-# LANGUAGE UnboxedTuples #-}
13
14 -- | Provide trees (of instructions), so that lists of instructions can be
15 -- appended in linear time.
16 module GHC.Data.OrdList (
17 OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,
18 nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
19 headOL,
20 mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
21 strictlyEqOL, strictlyOrdOL
22 ) where
23
24 import GHC.Prelude
25 import Data.Foldable
26
27 import GHC.Utils.Misc (strictMap)
28 import GHC.Utils.Outputable
29 import GHC.Utils.Panic
30
31 import qualified Data.Semigroup as Semigroup
32
33 infixl 5 `appOL`
34 infixl 5 `snocOL`
35 infixr 5 `consOL`
36
37 data OrdList a
38 = None
39 | One a
40 | Many [a] -- Invariant: non-empty
41 | Cons a (OrdList a)
42 | Snoc (OrdList a) a
43 | Two (OrdList a) -- Invariant: non-empty
44 (OrdList a) -- Invariant: non-empty
45 deriving (Functor)
46
47 instance Outputable a => Outputable (OrdList a) where
48 ppr ol = ppr (fromOL ol) -- Convert to list and print that
49
50 instance Semigroup (OrdList a) where
51 (<>) = appOL
52
53 instance Monoid (OrdList a) where
54 mempty = nilOL
55 mappend = (Semigroup.<>)
56 mconcat = concatOL
57
58 instance Foldable OrdList where
59 foldr = foldrOL
60 foldl' = foldlOL
61 toList = fromOL
62 null = isNilOL
63 length = lengthOL
64
65 instance Traversable OrdList where
66 traverse f xs = toOL <$> traverse f (fromOL xs)
67
68 nilOL :: OrdList a
69 isNilOL :: OrdList a -> Bool
70
71 unitOL :: a -> OrdList a
72 snocOL :: OrdList a -> a -> OrdList a
73 consOL :: a -> OrdList a -> OrdList a
74 appOL :: OrdList a -> OrdList a -> OrdList a
75 concatOL :: [OrdList a] -> OrdList a
76 headOL :: OrdList a -> a
77 lastOL :: OrdList a -> a
78 lengthOL :: OrdList a -> Int
79
80 nilOL = None
81 unitOL as = One as
82 snocOL as b = Snoc as b
83 consOL a bs = Cons a bs
84 concatOL aas = foldr appOL None aas
85
86 pattern NilOL :: OrdList a
87 pattern NilOL <- (isNilOL -> True) where
88 NilOL = None
89
90 -- | An unboxed 'Maybe' type with two unboxed fields in the 'Just' case.
91 -- Useful for defining 'viewCons' and 'viewSnoc' without overhead.
92 type VMaybe a b = (# (# a, b #) | (# #) #)
93 pattern VJust :: a -> b -> VMaybe a b
94 pattern VJust a b = (# (# a, b #) | #)
95 pattern VNothing :: VMaybe a b
96 pattern VNothing = (# | (# #) #)
97 {-# COMPLETE VJust, VNothing #-}
98
99 pattern ConsOL :: a -> OrdList a -> OrdList a
100 pattern ConsOL x xs <- (viewCons -> VJust x xs) where
101 ConsOL x xs = consOL x xs
102 {-# COMPLETE NilOL, ConsOL #-}
103 viewCons :: OrdList a -> VMaybe a (OrdList a)
104 viewCons (One a) = VJust a NilOL
105 viewCons (Cons a as) = VJust a as
106 viewCons (Snoc as a) = case viewCons as of
107 VJust a' as' -> VJust a' (Snoc as' a)
108 VNothing -> VJust a NilOL
109 viewCons (Two as1 as2) = case viewCons as1 of
110 VJust a' as1' -> VJust a' (Two as1' as2)
111 VNothing -> viewCons as2
112 viewCons _ = VNothing
113
114 pattern SnocOL :: OrdList a -> a -> OrdList a
115 pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where
116 SnocOL xs x = snocOL xs x
117 {-# COMPLETE NilOL, SnocOL #-}
118 viewSnoc :: OrdList a -> VMaybe (OrdList a) a
119 viewSnoc (One a) = VJust NilOL a
120 viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a
121 viewSnoc (Snoc as a) = VJust as a
122 viewSnoc (Cons a as) = case viewSnoc as of
123 VJust as' a' -> VJust (Cons a as') a'
124 VNothing -> VJust NilOL a
125 viewSnoc (Two as1 as2) = case viewSnoc as2 of
126 VJust as2' a' -> VJust (Two as1 as2') a'
127 VNothing -> viewSnoc as1
128 viewSnoc _ = VNothing
129
130 headOL None = panic "headOL"
131 headOL (One a) = a
132 headOL (Many as) = head as
133 headOL (Cons a _) = a
134 headOL (Snoc as _) = headOL as
135 headOL (Two as _) = headOL as
136
137 lastOL None = panic "lastOL"
138 lastOL (One a) = a
139 lastOL (Many as) = last as
140 lastOL (Cons _ as) = lastOL as
141 lastOL (Snoc _ a) = a
142 lastOL (Two _ as) = lastOL as
143
144 lengthOL None = 0
145 lengthOL (One _) = 1
146 lengthOL (Many as) = length as
147 lengthOL (Cons _ as) = 1 + length as
148 lengthOL (Snoc as _) = 1 + length as
149 lengthOL (Two as bs) = length as + length bs
150
151 isNilOL None = True
152 isNilOL _ = False
153
154 None `appOL` b = b
155 a `appOL` None = a
156 One a `appOL` b = Cons a b
157 a `appOL` One b = Snoc a b
158 a `appOL` b = Two a b
159
160 fromOL :: OrdList a -> [a]
161 fromOL a = go a []
162 where go None acc = acc
163 go (One a) acc = a : acc
164 go (Cons a b) acc = a : go b acc
165 go (Snoc a b) acc = go a (b:acc)
166 go (Two a b) acc = go a (go b acc)
167 go (Many xs) acc = xs ++ acc
168
169 fromOLReverse :: OrdList a -> [a]
170 fromOLReverse a = go a []
171 -- acc is already in reverse order
172 where go :: OrdList a -> [a] -> [a]
173 go None acc = acc
174 go (One a) acc = a : acc
175 go (Cons a b) acc = go b (a : acc)
176 go (Snoc a b) acc = b : go a acc
177 go (Two a b) acc = go b (go a acc)
178 go (Many xs) acc = reverse xs ++ acc
179
180 mapOL :: (a -> b) -> OrdList a -> OrdList b
181 mapOL = fmap
182
183 mapOL' :: (a->b) -> OrdList a -> OrdList b
184 mapOL' _ None = None
185 mapOL' f (One x) = One $! f x
186 mapOL' f (Cons x xs) = let !x1 = f x
187 !xs1 = mapOL' f xs
188 in Cons x1 xs1
189 mapOL' f (Snoc xs x) = let !x1 = f x
190 !xs1 = mapOL' f xs
191 in Snoc xs1 x1
192 mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1
193 !b2' = mapOL' f b2
194 in Two b1' b2'
195 mapOL' f (Many xs) = Many $! strictMap f xs
196
197 foldrOL :: (a->b->b) -> b -> OrdList a -> b
198 foldrOL _ z None = z
199 foldrOL k z (One x) = k x z
200 foldrOL k z (Cons x xs) = k x (foldrOL k z xs)
201 foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs
202 foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1
203 foldrOL k z (Many xs) = foldr k z xs
204
205 -- | Strict left fold.
206 foldlOL :: (b->a->b) -> b -> OrdList a -> b
207 foldlOL _ z None = z
208 foldlOL k z (One x) = k z x
209 foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs
210 foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x
211 foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2
212 foldlOL k z (Many xs) = foldl' k z xs
213
214 toOL :: [a] -> OrdList a
215 toOL [] = None
216 toOL [x] = One x
217 toOL xs = Many xs
218
219 reverseOL :: OrdList a -> OrdList a
220 reverseOL None = None
221 reverseOL (One x) = One x
222 reverseOL (Cons a b) = Snoc (reverseOL b) a
223 reverseOL (Snoc a b) = Cons b (reverseOL a)
224 reverseOL (Two a b) = Two (reverseOL b) (reverseOL a)
225 reverseOL (Many xs) = Many (reverse xs)
226
227 -- | Compare not only the values but also the structure of two lists
228 strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool
229 strictlyEqOL None None = True
230 strictlyEqOL (One x) (One y) = x == y
231 strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs
232 strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs
233 strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2
234 strictlyEqOL (Many as) (Many bs) = as == bs
235 strictlyEqOL _ _ = False
236
237 -- | Compare not only the values but also the structure of two lists
238 strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering
239 strictlyOrdOL None None = EQ
240 strictlyOrdOL None _ = LT
241 strictlyOrdOL (One x) (One y) = compare x y
242 strictlyOrdOL (One _) _ = LT
243 strictlyOrdOL (Cons a as) (Cons b bs) =
244 compare a b `mappend` strictlyOrdOL as bs
245 strictlyOrdOL (Cons _ _) _ = LT
246 strictlyOrdOL (Snoc as a) (Snoc bs b) =
247 compare a b `mappend` strictlyOrdOL as bs
248 strictlyOrdOL (Snoc _ _) _ = LT
249 strictlyOrdOL (Two a1 a2) (Two b1 b2) =
250 (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2)
251 strictlyOrdOL (Two _ _) _ = LT
252 strictlyOrdOL (Many as) (Many bs) = compare as bs
253 strictlyOrdOL (Many _ ) _ = GT