Hoopl: remove dependency on Hoopl package
[ghc.git] / compiler / cmm / Hoopl / Label.hs
1 {-# LANGUAGE DeriveFoldable #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE DeriveTraversable #-}
4 {-# LANGUAGE TypeFamilies #-}
5 module Hoopl.Label
6 ( Label
7 , LabelMap
8 , LabelSet
9 , FactBase
10 , lookupFact
11 , uniqueToLbl
12 ) where
13
14 import Outputable
15
16 import Hoopl.Collections
17 -- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
18 import Hoopl.Unique
19
20 import Unique (Uniquable(..))
21
22 -----------------------------------------------------------------------------
23 -- Label
24 -----------------------------------------------------------------------------
25
26 newtype Label = Label { lblToUnique :: Unique }
27 deriving (Eq, Ord)
28
29 uniqueToLbl :: Unique -> Label
30 uniqueToLbl = Label
31
32 instance Show Label where
33 show (Label n) = "L" ++ show n
34
35 instance Uniquable Label where
36 getUnique label = getUnique (lblToUnique label)
37
38 instance Outputable Label where
39 ppr label = ppr (getUnique label)
40
41 -----------------------------------------------------------------------------
42 -- LabelSet
43
44 newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
45
46 instance IsSet LabelSet where
47 type ElemOf LabelSet = Label
48
49 setNull (LS s) = setNull s
50 setSize (LS s) = setSize s
51 setMember (Label k) (LS s) = setMember k s
52
53 setEmpty = LS setEmpty
54 setSingleton (Label k) = LS (setSingleton k)
55 setInsert (Label k) (LS s) = LS (setInsert k s)
56 setDelete (Label k) (LS s) = LS (setDelete k s)
57
58 setUnion (LS x) (LS y) = LS (setUnion x y)
59 setDifference (LS x) (LS y) = LS (setDifference x y)
60 setIntersection (LS x) (LS y) = LS (setIntersection x y)
61 setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
62
63 setFold k z (LS s) = setFold (k . uniqueToLbl) z s
64
65 setElems (LS s) = map uniqueToLbl (setElems s)
66 setFromList ks = LS (setFromList (map lblToUnique ks))
67
68 -----------------------------------------------------------------------------
69 -- LabelMap
70
71 newtype LabelMap v = LM (UniqueMap v)
72 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
73
74 instance IsMap LabelMap where
75 type KeyOf LabelMap = Label
76
77 mapNull (LM m) = mapNull m
78 mapSize (LM m) = mapSize m
79 mapMember (Label k) (LM m) = mapMember k m
80 mapLookup (Label k) (LM m) = mapLookup k m
81 mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
82
83 mapEmpty = LM mapEmpty
84 mapSingleton (Label k) v = LM (mapSingleton k v)
85 mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
86 mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
87 mapDelete (Label k) (LM m) = LM (mapDelete k m)
88
89 mapUnion (LM x) (LM y) = LM (mapUnion x y)
90 mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
91 mapDifference (LM x) (LM y) = LM (mapDifference x y)
92 mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
93 mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
94
95 mapMap f (LM m) = LM (mapMap f m)
96 mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
97 mapFold k z (LM m) = mapFold k z m
98 mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
99 mapFilter f (LM m) = LM (mapFilter f m)
100
101 mapElems (LM m) = mapElems m
102 mapKeys (LM m) = map uniqueToLbl (mapKeys m)
103 mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
104 mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
105 mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
106
107 -----------------------------------------------------------------------------
108 -- Instances
109
110 instance Outputable LabelSet where
111 ppr = ppr . setElems
112
113 instance Outputable a => Outputable (LabelMap a) where
114 ppr = ppr . mapToList
115
116 -----------------------------------------------------------------------------
117 -- FactBase
118
119 type FactBase f = LabelMap f
120
121 lookupFact :: Label -> FactBase f -> Maybe f
122 lookupFact = mapLookup