Ticket #8782: OrdList.lhs

File OrdList.lhs, 4.1 KB (added by Iceland_jack, 17 months ago)

Rewritten version of ./compiler/utils/OrdList.lhs

Line 
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\begin{code}
12{-# LANGUAGE GADTs #-}
13{-# LANGUAGE DataKinds #-}
14{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeOperators #-}
16
17module OrdList (
18        OrdList,
19        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL,
20        fromOL, toOL
21) where
22
23import GHC.Exts
24import qualified Data.Foldable as F
25import Data.Monoid
26
27data IsEmpty = Empty | NonEmpty
28
29type family (x :: IsEmpty) :+: (y :: IsEmpty) :: IsEmpty where
30  Empty    :+: e        = e
31  e        :+: Empty    = e
32  e        :+: f        = NonEmpty
33
34data OrdList' :: IsEmpty -> * -> * where
35  None ::                                               OrdList' Empty    a
36  One  :: a                                          -> OrdList' NonEmpty a
37  Many :: a                   -> [a]                 -> OrdList' NonEmpty a
38  Cons :: a                   -> OrdList' f a        -> OrdList' NonEmpty a
39  Snoc :: OrdList' f a        -> a                   -> OrdList' NonEmpty a
40  Two  :: OrdList' NonEmpty a -> OrdList' NonEmpty a -> OrdList' NonEmpty a
41
42data OrdList a where
43  OL :: OrdList' e a -> OrdList a
44
45data MaybeEmpty :: IsEmpty -> * -> * where
46  IsEmpty    :: MaybeEmpty Empty a
47  IsNonEmpty :: OrdList' NonEmpty a -> MaybeEmpty NonEmpty a
48
49check :: OrdList' e a -> MaybeEmpty e a
50check a = case a of
51  None   -> IsEmpty
52  One{}  -> IsNonEmpty a
53  Many{} -> IsNonEmpty a
54  Cons{} -> IsNonEmpty a
55  Snoc{} -> IsNonEmpty a
56  Two{}  -> IsNonEmpty a
57
58nilOL :: OrdList a
59nilOL = OL None
60
61isNilOL :: OrdList a -> Bool
62isNilOL (OL None) = True
63isNilOL _         = False
64
65unitOL :: a -> OrdList a
66unitOL as = OL (One as)
67
68infixl 5  `snocOL`
69snocOL :: OrdList a -> a -> OrdList a
70snocOL (OL xs) x = OL (Snoc xs x)
71
72infixr 5  `consOL`
73consOL :: a -> OrdList a -> OrdList a
74consOL x (OL xs) = OL (Cons x xs)
75
76infixl 5 `appOL`
77appOL :: OrdList t -> OrdList t -> OrdList t
78appOL (OL xs) (OL ys) = OL (aux xs ys) where
79  aux :: OrdList' f a -> OrdList' g a -> OrdList' (f :+: g) a
80  aux xs ys = case (check xs, check ys) of
81    (IsEmpty,            IsEmpty)            -> None
82    (IsEmpty,            IsNonEmpty b)       -> b
83    (IsNonEmpty a,       IsEmpty)            -> a
84    (IsNonEmpty (One a), IsNonEmpty b)       -> Cons a b
85    (IsNonEmpty a,       IsNonEmpty (One b)) -> Snoc a b
86    (IsNonEmpty a,       IsNonEmpty b)       -> Two a b
87
88concatOL :: [OrdList a] -> OrdList a
89concatOL = foldr appOL nilOL
90
91fromOL :: OrdList a -> [a]
92fromOL (OL xs) = go [] xs where
93  go :: [a] -> OrdList' e a -> [a]
94  go acc None        = acc
95  go acc (One a)     = a : acc
96  go acc (Cons a b)  = a : go acc b
97  go acc (Snoc a b)  = go (b:acc) a
98  go acc (Two a b)   = go (go acc b) a
99  go acc (Many x xs) = x:xs ++ acc
100
101instance Functor (OrdList' e) where
102  fmap _ None        = None
103  fmap f (One x)     = One (f x)
104  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
105  fmap f (Snoc xs x) = Snoc (fmap f xs) (f x)
106  fmap f (Two xs ys) = Two (fmap f xs) (fmap f ys)
107  fmap f (Many x xs) = Many (f x) (map f xs)
108
109instance Functor OrdList where
110  fmap f (OL ol) = OL (fmap f ol)
111
112instance F.Foldable (OrdList' e) where
113  foldr _ z None        = z
114  foldr k z (One x)     = k x z
115  foldr k z (Cons x xs) = k x (F.foldr k z xs)
116  foldr k z (Snoc xs x) = F.foldr k (k x z) xs
117  foldr k z (Two b1 b2) = F.foldr k (F.foldr k z b2) b1
118  foldr k z (Many x xs) = F.foldr k z (x:xs)
119
120  foldl _ z None        = z
121  foldl k z (One x)     = k z x
122  foldl k z (Cons x xs) = F.foldl k (k z x) xs
123  foldl k z (Snoc xs x) = k (F.foldl k z xs) x
124  foldl k z (Two b1 b2) = F.foldl k (F.foldl k z b1) b2
125  foldl k z (Many x xs) = F.foldl k z (x:xs)
126
127instance F.Foldable OrdList where
128  foldr k z (OL ol) = F.foldr k z ol
129  foldl k z (OL ol) = F.foldl k z ol
130
131toOL :: [a] -> OrdList a
132toOL []     = OL None
133toOL (x:xs) = OL (Many x xs)
134
135instance IsList (OrdList a) where
136  type Item (OrdList a) = a
137  fromList = toOL
138  toList   = fromOL
139 
140instance Monoid (OrdList a) where
141  mempty  = nilOL
142  mappend = appOL
143\end{code}