Check for singletons when creating Bag/OrdList from a list.
[ghc.git] / compiler / utils / OrdList.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1993-1998
4
5
6 This is useful, general stuff for the Native Code Generator.
7
8 Provide trees (of instructions), so that lists of instructions
9 can be appended in linear time.
10 -}
11
12 module OrdList (
13 OrdList,
14 nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
15 mapOL, fromOL, toOL, foldrOL, foldlOL
16 ) where
17
18 import GhcPrelude
19
20 import Outputable
21
22 import Data.Semigroup ( Semigroup )
23 import qualified Data.Semigroup as Semigroup
24
25 infixl 5 `appOL`
26 infixl 5 `snocOL`
27 infixr 5 `consOL`
28
29 data OrdList a
30 = None
31 | One a
32 | Many [a] -- Invariant: non-empty
33 | Cons a (OrdList a)
34 | Snoc (OrdList a) a
35 | Two (OrdList a) -- Invariant: non-empty
36 (OrdList a) -- Invariant: non-empty
37
38 instance Outputable a => Outputable (OrdList a) where
39 ppr ol = ppr (fromOL ol) -- Convert to list and print that
40
41 instance Semigroup (OrdList a) where
42 (<>) = appOL
43
44 instance Monoid (OrdList a) where
45 mempty = nilOL
46 mappend = (Semigroup.<>)
47 mconcat = concatOL
48
49 instance Functor OrdList where
50 fmap = mapOL
51
52 instance Foldable OrdList where
53 foldr = foldrOL
54
55 instance Traversable OrdList where
56 traverse f xs = toOL <$> traverse f (fromOL xs)
57
58 nilOL :: OrdList a
59 isNilOL :: OrdList a -> Bool
60
61 unitOL :: a -> OrdList a
62 snocOL :: OrdList a -> a -> OrdList a
63 consOL :: a -> OrdList a -> OrdList a
64 appOL :: OrdList a -> OrdList a -> OrdList a
65 concatOL :: [OrdList a] -> OrdList a
66 lastOL :: OrdList a -> a
67
68 nilOL = None
69 unitOL as = One as
70 snocOL as b = Snoc as b
71 consOL a bs = Cons a bs
72 concatOL aas = foldr appOL None aas
73
74 lastOL None = panic "lastOL"
75 lastOL (One a) = a
76 lastOL (Many as) = last as
77 lastOL (Cons _ as) = lastOL as
78 lastOL (Snoc _ a) = a
79 lastOL (Two _ as) = lastOL as
80
81 isNilOL None = True
82 isNilOL _ = False
83
84 None `appOL` b = b
85 a `appOL` None = a
86 One a `appOL` b = Cons a b
87 a `appOL` One b = Snoc a b
88 a `appOL` b = Two a b
89
90 fromOL :: OrdList a -> [a]
91 fromOL a = go a []
92 where go None acc = acc
93 go (One a) acc = a : acc
94 go (Cons a b) acc = a : go b acc
95 go (Snoc a b) acc = go a (b:acc)
96 go (Two a b) acc = go a (go b acc)
97 go (Many xs) acc = xs ++ acc
98
99 mapOL :: (a -> b) -> OrdList a -> OrdList b
100 mapOL _ None = None
101 mapOL f (One x) = One (f x)
102 mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)
103 mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)
104 mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)
105 mapOL f (Many xs) = Many (map f xs)
106
107 foldrOL :: (a->b->b) -> b -> OrdList a -> b
108 foldrOL _ z None = z
109 foldrOL k z (One x) = k x z
110 foldrOL k z (Cons x xs) = k x (foldrOL k z xs)
111 foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs
112 foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1
113 foldrOL k z (Many xs) = foldr k z xs
114
115 foldlOL :: (b->a->b) -> b -> OrdList a -> b
116 foldlOL _ z None = z
117 foldlOL k z (One x) = k z x
118 foldlOL k z (Cons x xs) = foldlOL k (k z x) xs
119 foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x
120 foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2
121 foldlOL k z (Many xs) = foldl k z xs
122
123 toOL :: [a] -> OrdList a
124 toOL [] = None
125 toOL [x] = One x
126 toOL xs = Many xs