%
% (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.
\begin{code}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module OrdList (
OrdList,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL,
fromOL, toOL
) where
import GHC.Exts
import qualified Data.Foldable as F
import Data.Monoid
data IsEmpty = Empty | NonEmpty
type family (x :: IsEmpty) :+: (y :: IsEmpty) :: IsEmpty where
Empty :+: e = e
e :+: Empty = e
e :+: f = NonEmpty
data OrdList' :: IsEmpty -> * -> * where
None :: OrdList' Empty a
One :: a -> OrdList' NonEmpty a
Many :: a -> [a] -> OrdList' NonEmpty a
Cons :: a -> OrdList' f a -> OrdList' NonEmpty a
Snoc :: OrdList' f a -> a -> OrdList' NonEmpty a
Two :: OrdList' NonEmpty a -> OrdList' NonEmpty a -> OrdList' NonEmpty a
data OrdList a where
OL :: OrdList' e a -> OrdList a
data MaybeEmpty :: IsEmpty -> * -> * where
IsEmpty :: MaybeEmpty Empty a
IsNonEmpty :: OrdList' NonEmpty a -> MaybeEmpty NonEmpty a
check :: OrdList' e a -> MaybeEmpty e a
check a = case a of
None -> IsEmpty
One{} -> IsNonEmpty a
Many{} -> IsNonEmpty a
Cons{} -> IsNonEmpty a
Snoc{} -> IsNonEmpty a
Two{} -> IsNonEmpty a
nilOL :: OrdList a
nilOL = OL None
isNilOL :: OrdList a -> Bool
isNilOL (OL None) = True
isNilOL _ = False
unitOL :: a -> OrdList a
unitOL as = OL (One as)
infixl 5 `snocOL`
snocOL :: OrdList a -> a -> OrdList a
snocOL (OL xs) x = OL (Snoc xs x)
infixr 5 `consOL`
consOL :: a -> OrdList a -> OrdList a
consOL x (OL xs) = OL (Cons x xs)
infixl 5 `appOL`
appOL :: OrdList t -> OrdList t -> OrdList t
appOL (OL xs) (OL ys) = OL (aux xs ys) where
aux :: OrdList' f a -> OrdList' g a -> OrdList' (f :+: g) a
aux xs ys = case (check xs, check ys) of
(IsEmpty, IsEmpty) -> None
(IsEmpty, IsNonEmpty b) -> b
(IsNonEmpty a, IsEmpty) -> a
(IsNonEmpty (One a), IsNonEmpty b) -> Cons a b
(IsNonEmpty a, IsNonEmpty (One b)) -> Snoc a b
(IsNonEmpty a, IsNonEmpty b) -> Two a b
concatOL :: [OrdList a] -> OrdList a
concatOL = foldr appOL nilOL
fromOL :: OrdList a -> [a]
fromOL (OL xs) = go [] xs where
go :: [a] -> OrdList' e a -> [a]
go acc None = acc
go acc (One a) = a : acc
go acc (Cons a b) = a : go acc b
go acc (Snoc a b) = go (b:acc) a
go acc (Two a b) = go (go acc b) a
go acc (Many x xs) = x:xs ++ acc
instance Functor (OrdList' e) where
fmap _ None = None
fmap f (One x) = One (f x)
fmap f (Cons x xs) = Cons (f x) (fmap f xs)
fmap f (Snoc xs x) = Snoc (fmap f xs) (f x)
fmap f (Two xs ys) = Two (fmap f xs) (fmap f ys)
fmap f (Many x xs) = Many (f x) (map f xs)
instance Functor OrdList where
fmap f (OL ol) = OL (fmap f ol)
instance F.Foldable (OrdList' e) where
foldr _ z None = z
foldr k z (One x) = k x z
foldr k z (Cons x xs) = k x (F.foldr k z xs)
foldr k z (Snoc xs x) = F.foldr k (k x z) xs
foldr k z (Two b1 b2) = F.foldr k (F.foldr k z b2) b1
foldr k z (Many x xs) = F.foldr k z (x:xs)
foldl _ z None = z
foldl k z (One x) = k z x
foldl k z (Cons x xs) = F.foldl k (k z x) xs
foldl k z (Snoc xs x) = k (F.foldl k z xs) x
foldl k z (Two b1 b2) = F.foldl k (F.foldl k z b1) b2
foldl k z (Many x xs) = F.foldl k z (x:xs)
instance F.Foldable OrdList where
foldr k z (OL ol) = F.foldr k z ol
foldl k z (OL ol) = F.foldl k z ol
toOL :: [a] -> OrdList a
toOL [] = OL None
toOL (x:xs) = OL (Many x xs)
instance IsList (OrdList a) where
type Item (OrdList a) = a
fromList = toOL
toList = fromOL
instance Monoid (OrdList a) where
mempty = nilOL
mappend = appOL
\end{code}