Put back the newtype around Label
[packages/hoopl.git] / src / Compiler / Hoopl / Label.hs
1 {-# LANGUAGE TypeFamilies #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Safe #-}
4 #endif
5
6 module Compiler.Hoopl.Label
7 ( Label
8 , freshLabel
9 , LabelSet, LabelMap
10 , FactBase, noFacts, lookupFact
11
12 , uniqueToLbl -- MkGraph and GHC use only
13 , lblToUnique -- GHC use only
14 )
15
16 where
17
18 import Compiler.Hoopl.Collections
19 import Compiler.Hoopl.Unique
20
21 -----------------------------------------------------------------------------
22 -- Label
23 -----------------------------------------------------------------------------
24
25 newtype Label = Label { lblToUnique :: Unique }
26 deriving (Eq, Ord)
27
28 uniqueToLbl :: Unique -> Label
29 uniqueToLbl = Label
30
31 instance Show Label where
32 show (Label n) = "L" ++ show n
33
34 freshLabel :: UniqueMonad m => m Label
35 freshLabel = freshUnique >>= return . uniqueToLbl
36
37 -----------------------------------------------------------------------------
38 -- LabelSet
39
40 newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
41
42 instance IsSet LabelSet where
43 type ElemOf LabelSet = Label
44
45 setNull (LS s) = setNull s
46 setSize (LS s) = setSize s
47 setMember (Label k) (LS s) = setMember k s
48
49 setEmpty = LS setEmpty
50 setSingleton (Label k) = LS (setSingleton k)
51 setInsert (Label k) (LS s) = LS (setInsert k s)
52 setDelete (Label k) (LS s) = LS (setDelete k s)
53
54 setUnion (LS x) (LS y) = LS (setUnion x y)
55 setDifference (LS x) (LS y) = LS (setDifference x y)
56 setIntersection (LS x) (LS y) = LS (setIntersection x y)
57 setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
58
59 setFold k z (LS s) = setFold (k . uniqueToLbl) z s
60
61 setElems (LS s) = map uniqueToLbl (setElems s)
62 setFromList ks = LS (setFromList (map lblToUnique ks))
63
64 -----------------------------------------------------------------------------
65 -- LabelMap
66
67 newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)
68
69 instance IsMap LabelMap where
70 type KeyOf LabelMap = Label
71
72 mapNull (LM m) = mapNull m
73 mapSize (LM m) = mapSize m
74 mapMember (Label k) (LM m) = mapMember k m
75 mapLookup (Label k) (LM m) = mapLookup k m
76 mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
77
78 mapEmpty = LM mapEmpty
79 mapSingleton (Label k) v = LM (mapSingleton k v)
80 mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
81 mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
82 mapDelete (Label k) (LM m) = LM (mapDelete k m)
83
84 mapUnion (LM x) (LM y) = LM (mapUnion x y)
85 mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
86 mapDifference (LM x) (LM y) = LM (mapDifference x y)
87 mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
88 mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
89
90 mapMap f (LM m) = LM (mapMap f m)
91 mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
92 mapFold k z (LM m) = mapFold k z m
93 mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
94
95 mapElems (LM m) = mapElems m
96 mapKeys (LM m) = map uniqueToLbl (mapKeys m)
97 mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
98 mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
99 mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
100
101 -----------------------------------------------------------------------------
102 -- FactBase
103
104 type FactBase f = LabelMap f
105
106 noFacts :: FactBase f
107 noFacts = mapEmpty
108
109 lookupFact :: Label -> FactBase f -> Maybe f
110 lookupFact = mapLookup