1{-
2(c) The University of Glasgow 2006
3(c) The AQUA Project, Glasgow University, 1993-1998
4
5
6This is useful, general stuff for the Native Code Generator.
7
8Provide trees (of instructions), so that lists of instructions
9can be appended in linear time.
10-}
11{-# LANGUAGE DeriveFunctor #-}
12
13{-# LANGUAGE BangPatterns #-}
14
15module OrdList (
16        OrdList,
17        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
18        headOL,
19        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
20        strictlyEqOL, strictlyOrdOL
21) where
22
23import GhcPrelude
24import Data.Foldable
25
26import Outputable
27
28import qualified Data.Semigroup as Semigroup
29
30infixl 5  `appOL`
31infixl 5  `snocOL`
32infixr 5  `consOL`
33
34data OrdList a
35  = None
36  | One a
37  | Many [a]          -- Invariant: non-empty
38  | Cons a (OrdList a)
39  | Snoc (OrdList a) a
40  | Two (OrdList a) -- Invariant: non-empty
41        (OrdList a) -- Invariant: non-empty
42  deriving (Functor)
43
44instance Outputable a => Outputable (OrdList a) where
45  ppr ol = ppr (fromOL ol)  -- Convert to list and print that
46
47instance Semigroup (OrdList a) where
48  (<>) = appOL
49
50instance Monoid (OrdList a) where
51  mempty = nilOL
52  mappend = (Semigroup.<>)
53  mconcat = concatOL
54
55instance Foldable OrdList where
56  foldr   = foldrOL
57  foldl'  = foldlOL
58  toList  = fromOL
59  null    = isNilOL
60  length  = lengthOL
61
62instance Traversable OrdList where
63  traverse f xs = toOL <$> traverse f (fromOL xs)
64
65nilOL    :: OrdList a
66isNilOL  :: OrdList a -> Bool
67
68unitOL   :: a           -> OrdList a
69snocOL   :: OrdList a   -> a         -> OrdList a
70consOL   :: a           -> OrdList a -> OrdList a
71appOL    :: OrdList a   -> OrdList a -> OrdList a
72concatOL :: [OrdList a] -> OrdList a
73headOL   :: OrdList a   -> a
74lastOL   :: OrdList a   -> a
75lengthOL :: OrdList a   -> Int
76
77nilOL        = None
78unitOL as    = One as
79snocOL as   b    = Snoc as b
80consOL a    bs   = Cons a bs
81concatOL aas = foldr appOL None aas
82
83headOL None        = panic "headOL"
84headOL (One a)     = a
85headOL (Many as)   = head as
86headOL (Cons a _)  = a
87headOL (Snoc as _) = headOL as
88headOL (Two as _)  = headOL as
89
90lastOL None        = panic "lastOL"
91lastOL (One a)     = a
92lastOL (Many as)   = last as
93lastOL (Cons _ as) = lastOL as
94lastOL (Snoc _ a)  = a
95lastOL (Two _ as)  = lastOL as
96
97lengthOL None        = 0
98lengthOL (One _)     = 1
99lengthOL (Many as)   = length as
100lengthOL (Cons _ as) = 1 + length as
101lengthOL (Snoc as _) = 1 + length as
102lengthOL (Two as bs) = length as + length bs
103
104isNilOL None = True
105isNilOL _    = False
106
107None  `appOL` b     = b
108a     `appOL` None  = a
109One a `appOL` b     = Cons a b
110a     `appOL` One b = Snoc a b
111a     `appOL` b     = Two a b
112
113fromOL :: OrdList a -> [a]
114fromOL a = go a []
115  where go None       acc = acc
116        go (One a)    acc = a : acc
117        go (Cons a b) acc = a : go b acc
118        go (Snoc a b) acc = go a (b:acc)
119        go (Two a b)  acc = go a (go b acc)
120        go (Many xs)  acc = xs ++ acc
121
122fromOLReverse :: OrdList a -> [a]
123fromOLReverse a = go a []
124        -- acc is already in reverse order
125  where go :: OrdList a -> [a] -> [a]
126        go None       acc = acc
127        go (One a)    acc = a : acc
128        go (Cons a b) acc = go b (a : acc)
129        go (Snoc a b) acc = b : go a acc
130        go (Two a b)  acc = go b (go a acc)
131        go (Many xs)  acc = reverse xs ++ acc
132
133mapOL :: (a -> b) -> OrdList a -> OrdList b
134mapOL = fmap
135
136foldrOL :: (a->b->b) -> b -> OrdList a -> b
137foldrOL _ z None        = z
138foldrOL k z (One x)     = k x z
139foldrOL k z (Cons x xs) = k x (foldrOL k z xs)
140foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs
141foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1
142foldrOL k z (Many xs)   = foldr k z xs
143
144-- | Strict left fold.
145foldlOL :: (b->a->b) -> b -> OrdList a -> b
146foldlOL _ z None        = z
147foldlOL k z (One x)     = k z x
148foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs
149foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x
150foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2
151foldlOL k z (Many xs)   = foldl' k z xs
152
153toOL :: [a] -> OrdList a
154toOL [] = None
155toOL [x] = One x
156toOL xs = Many xs
157
158reverseOL :: OrdList a -> OrdList a
159reverseOL None = None
160reverseOL (One x) = One x
161reverseOL (Cons a b) = Snoc (reverseOL b) a
162reverseOL (Snoc a b) = Cons b (reverseOL a)
163reverseOL (Two a b)  = Two (reverseOL b) (reverseOL a)
164reverseOL (Many xs)  = Many (reverse xs)
165
166-- | Compare not only the values but also the structure of two lists
167strictlyEqOL :: Eq a => OrdList a   -> OrdList a -> Bool
168strictlyEqOL None         None       = True
169strictlyEqOL (One x)     (One y)     = x == y
170strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs
171strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs
172strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2
173strictlyEqOL (Many as)   (Many bs)   = as == bs
174strictlyEqOL _            _          = False
175
176-- | Compare not only the values but also the structure of two lists
177strictlyOrdOL :: Ord a => OrdList a   -> OrdList a -> Ordering
178strictlyOrdOL None         None       = EQ
179strictlyOrdOL None         _          = LT
180strictlyOrdOL (One x)     (One y)     = compare x y
181strictlyOrdOL (One _)      _          = LT
182strictlyOrdOL (Cons a as) (Cons b bs) =
183  compare a b `mappend` strictlyOrdOL as bs
184strictlyOrdOL (Cons _ _)   _          = LT
185strictlyOrdOL (Snoc as a) (Snoc bs b) =
186  compare a b `mappend` strictlyOrdOL as bs
187strictlyOrdOL (Snoc _ _)   _          = LT
188strictlyOrdOL (Two a1 a2) (Two b1 b2) =
189  (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2)
190strictlyOrdOL (Two _ _)    _          = LT
191strictlyOrdOL (Many as)   (Many bs)   = compare as bs
192strictlyOrdOL (Many _ )   _           = GT
193
194
195