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