{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998
This is useful, general stuff for the Native Code Generator.
Provide trees (of instructions), so that lists of instructions
can be appended in linear time.
-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}
module OrdList (
OrdList,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
headOL,
mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
strictlyEqOL, strictlyOrdOL
) where
import GhcPrelude
import Data.Foldable
import Outputable
import qualified Data.Semigroup as Semigroup
infixl 5 `appOL`
infixl 5 `snocOL`
infixr 5 `consOL`
data OrdList a
= None
| One a
| Many [a] -- Invariant: non-empty
| Cons a (OrdList a)
| Snoc (OrdList a) a
| Two (OrdList a) -- Invariant: non-empty
(OrdList a) -- Invariant: non-empty
deriving (Functor)
instance Outputable a => Outputable (OrdList a) where
ppr ol = ppr (fromOL ol) -- Convert to list and print that
instance Semigroup (OrdList a) where
(<>) = appOL
instance Monoid (OrdList a) where
mempty = nilOL
mappend = (Semigroup.<>)
mconcat = concatOL
instance Foldable OrdList where
foldr = foldrOL
foldl' = foldlOL
toList = fromOL
null = isNilOL
length = lengthOL
instance Traversable OrdList where
traverse f xs = toOL <$> traverse f (fromOL xs)
nilOL :: OrdList a
isNilOL :: OrdList a -> Bool
unitOL :: a -> OrdList a
snocOL :: OrdList a -> a -> OrdList a
consOL :: a -> OrdList a -> OrdList a
appOL :: OrdList a -> OrdList a -> OrdList a
concatOL :: [OrdList a] -> OrdList a
headOL :: OrdList a -> a
lastOL :: OrdList a -> a
lengthOL :: OrdList a -> Int
nilOL = None
unitOL as = One as
snocOL as b = Snoc as b
consOL a bs = Cons a bs
concatOL aas = foldr appOL None aas
headOL None = panic "headOL"
headOL (One a) = a
headOL (Many as) = head as
headOL (Cons a _) = a
headOL (Snoc as _) = headOL as
headOL (Two as _) = headOL as
lastOL None = panic "lastOL"
lastOL (One a) = a
lastOL (Many as) = last as
lastOL (Cons _ as) = lastOL as
lastOL (Snoc _ a) = a
lastOL (Two _ as) = lastOL as
lengthOL None = 0
lengthOL (One _) = 1
lengthOL (Many as) = length as
lengthOL (Cons _ as) = 1 + length as
lengthOL (Snoc as _) = 1 + length as
lengthOL (Two as bs) = length as + length bs
isNilOL None = True
isNilOL _ = False
None `appOL` b = b
a `appOL` None = a
One a `appOL` b = Cons a b
a `appOL` One b = Snoc a b
a `appOL` b = Two a b
fromOL :: OrdList a -> [a]
fromOL a = go a []
where go None acc = acc
go (One a) acc = a : acc
go (Cons a b) acc = a : go b acc
go (Snoc a b) acc = go a (b:acc)
go (Two a b) acc = go a (go b acc)
go (Many xs) acc = xs ++ acc
fromOLReverse :: OrdList a -> [a]
fromOLReverse a = go a []
-- acc is already in reverse order
where go :: OrdList a -> [a] -> [a]
go None acc = acc
go (One a) acc = a : acc
go (Cons a b) acc = go b (a : acc)
go (Snoc a b) acc = b : go a acc
go (Two a b) acc = go b (go a acc)
go (Many xs) acc = reverse xs ++ acc
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL = fmap
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL _ z None = z
foldrOL k z (One x) = k x z
foldrOL k z (Cons x xs) = k x (foldrOL k z xs)
foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs
foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1
foldrOL k z (Many xs) = foldr k z xs
-- | Strict left fold.
foldlOL :: (b->a->b) -> b -> OrdList a -> b
foldlOL _ z None = z
foldlOL k z (One x) = k z x
foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs
foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x
foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2
foldlOL k z (Many xs) = foldl' k z xs
toOL :: [a] -> OrdList a
toOL [] = None
toOL [x] = One x
toOL xs = Many xs
reverseOL :: OrdList a -> OrdList a
reverseOL None = None
reverseOL (One x) = One x
reverseOL (Cons a b) = Snoc (reverseOL b) a
reverseOL (Snoc a b) = Cons b (reverseOL a)
reverseOL (Two a b) = Two (reverseOL b) (reverseOL a)
reverseOL (Many xs) = Many (reverse xs)
-- | Compare not only the values but also the structure of two lists
strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool
strictlyEqOL None None = True
strictlyEqOL (One x) (One y) = x == y
strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs
strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs
strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2
strictlyEqOL (Many as) (Many bs) = as == bs
strictlyEqOL _ _ = False
-- | Compare not only the values but also the structure of two lists
strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL None None = EQ
strictlyOrdOL None _ = LT
strictlyOrdOL (One x) (One y) = compare x y
strictlyOrdOL (One _) _ = LT
strictlyOrdOL (Cons a as) (Cons b bs) =
compare a b `mappend` strictlyOrdOL as bs
strictlyOrdOL (Cons _ _) _ = LT
strictlyOrdOL (Snoc as a) (Snoc bs b) =
compare a b `mappend` strictlyOrdOL as bs
strictlyOrdOL (Snoc _ _) _ = LT
strictlyOrdOL (Two a1 a2) (Two b1 b2) =
(strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2)
strictlyOrdOL (Two _ _) _ = LT
strictlyOrdOL (Many as) (Many bs) = compare as bs
strictlyOrdOL (Many _ ) _ = GT