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