99c3b45a7a818970b3f7c3b3472b07d5f0345967
[packages/hoopl.git] / src / Compiler / Hoopl / Unique.hs
1 {-# LANGUAGE TypeFamilies #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5
6 module Compiler.Hoopl.Unique
7 ( Unique, intToUnique
8 , UniqueSet, UniqueMap
9 , UniqueMonad(..)
10 , SimpleUniqueMonad, runSimpleUniqueMonad
11 , UniqueMonadT, runUniqueMonadT
12
13 , uniqueToInt -- exposed through GHC module only!
14 )
15
16 where
17
18 import Compiler.Hoopl.Checkpoint
19 import Compiler.Hoopl.Collections
20
21 import qualified Data.IntMap as M
22 import qualified Data.IntSet as S
23
24 -----------------------------------------------------------------------------
25 -- Unique
26 -----------------------------------------------------------------------------
27
28 data Unique = Unique { uniqueToInt :: {-# UNPACK #-} !Int }
29 deriving (Eq, Ord)
30
31 intToUnique :: Int -> Unique
32 intToUnique = Unique
33
34 instance Show Unique where
35 show (Unique n) = show n
36
37 -----------------------------------------------------------------------------
38 -- UniqueSet
39
40 newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
41
42 instance IsSet UniqueSet where
43 type ElemOf UniqueSet = Unique
44
45 setNull (US s) = S.null s
46 setSize (US s) = S.size s
47 setMember (Unique k) (US s) = S.member k s
48
49 setEmpty = US S.empty
50 setSingleton (Unique k) = US (S.singleton k)
51 setInsert (Unique k) (US s) = US (S.insert k s)
52 setDelete (Unique k) (US s) = US (S.delete k s)
53
54 setUnion (US x) (US y) = US (S.union x y)
55 setDifference (US x) (US y) = US (S.difference x y)
56 setIntersection (US x) (US y) = US (S.intersection x y)
57 setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
58
59 setFold k z (US s) = S.fold (k . intToUnique) z s
60
61 setElems (US s) = map intToUnique (S.elems s)
62 setFromList ks = US (S.fromList (map uniqueToInt ks))
63
64 -----------------------------------------------------------------------------
65 -- UniqueMap
66
67 newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show)
68
69 instance IsMap UniqueMap where
70 type KeyOf UniqueMap = Unique
71
72 mapNull (UM m) = M.null m
73 mapSize (UM m) = M.size m
74 mapMember (Unique k) (UM m) = M.member k m
75 mapLookup (Unique k) (UM m) = M.lookup k m
76 mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m
77
78 mapEmpty = UM M.empty
79 mapSingleton (Unique k) v = UM (M.singleton k v)
80 mapInsert (Unique k) v (UM m) = UM (M.insert k v m)
81 mapInsertWith f (Unique k) v (UM m) = UM (M.insertWith f k v m)
82 mapDelete (Unique k) (UM m) = UM (M.delete k m)
83
84 mapUnion (UM x) (UM y) = UM (M.union x y)
85 mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)
86 mapDifference (UM x) (UM y) = UM (M.difference x y)
87 mapIntersection (UM x) (UM y) = UM (M.intersection x y)
88 mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
89
90 mapMap f (UM m) = UM (M.map f m)
91 mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)
92 mapFold k z (UM m) = M.fold k z m
93 mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m
94
95 mapElems (UM m) = M.elems m
96 mapKeys (UM m) = map intToUnique (M.keys m)
97 mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]
98 mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])
99 mapFromListWith f assocs = UM (M.fromListWith f [(uniqueToInt k, v) | (k, v) <- assocs])
100
101 ----------------------------------------------------------------
102 -- Monads
103
104 class Monad m => UniqueMonad m where
105 freshUnique :: m Unique
106
107 newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) }
108
109 instance Monad SimpleUniqueMonad where
110 return a = SUM $ \us -> (a, us)
111 m >>= k = SUM $ \us -> let (a, us') = unSUM m us in
112 unSUM (k a) us'
113
114 instance UniqueMonad SimpleUniqueMonad where
115 freshUnique = SUM $ f
116 where f (u:us) = (u, us)
117 f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list"
118
119 instance CheckpointMonad SimpleUniqueMonad where
120 type Checkpoint SimpleUniqueMonad = [Unique]
121 checkpoint = SUM $ \us -> (us, us)
122 restart us = SUM $ \_ -> ((), us)
123
124 runSimpleUniqueMonad :: SimpleUniqueMonad a -> a
125 runSimpleUniqueMonad m = fst (unSUM m allUniques)
126
127 ----------------------------------------------------------------
128
129 newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) }
130
131 instance Monad m => Monad (UniqueMonadT m) where
132 return a = UMT $ \us -> return (a, us)
133 m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' }
134
135 instance Monad m => UniqueMonad (UniqueMonadT m) where
136 freshUnique = UMT $ f
137 where f (u:us) = return (u, us)
138 f _ = error "Unique.freshUnique(UniqueMonadT): empty list"
139
140 runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a
141 runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }
142
143 allUniques :: [Unique]
144 allUniques = map Unique [1..]