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