1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
{-
(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.
-}
module OrdList (
OrdList,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
mapOL, fromOL, toOL, foldrOL, foldlOL
) where
import GhcPrelude
import Outputable
import Data.Semigroup ( Semigroup )
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
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 Functor OrdList where
fmap = mapOL
instance Foldable OrdList where
foldr = foldrOL
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
lastOL :: OrdList a -> a
nilOL = None
unitOL as = One as
snocOL as b = Snoc as b
consOL a bs = Cons a bs
concatOL aas = foldr appOL None aas
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
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
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL _ None = None
mapOL f (One x) = One (f x)
mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)
mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)
mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)
mapOL f (Many xs) = Many (map f xs)
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
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) = foldlOL k (k z x) xs
foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x
foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2
foldlOL k z (Many xs) = foldl k z xs
toOL :: [a] -> OrdList a
toOL [] = None
toOL xs = Many xs
|
