Change the block representation (version bumped to 3.9.0.0)
[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 type Unique = Int
29
30 uniqueToInt :: Unique -> Int
31 uniqueToInt = id
32
33 intToUnique :: Int -> Unique
34 intToUnique = id
35
36 -----------------------------------------------------------------------------
37 -- UniqueSet
38
39 newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
40
41 instance IsSet UniqueSet where
42 type ElemOf UniqueSet = Unique
43
44 setNull (US s) = S.null s
45 setSize (US s) = S.size s
46 setMember k (US s) = S.member k s
47
48 setEmpty = US S.empty
49 setSingleton k = US (S.singleton k)
50 setInsert k (US s) = US (S.insert k s)
51 setDelete k (US s) = US (S.delete k s)
52
53 setUnion (US x) (US y) = US (S.union x y)
54 setDifference (US x) (US y) = US (S.difference x y)
55 setIntersection (US x) (US y) = US (S.intersection x y)
56 setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
57
58 setFold k z (US s) = S.fold k z s
59
60 setElems (US s) = S.elems s
61 setFromList ks = US (S.fromList ks)
62
63 -----------------------------------------------------------------------------
64 -- UniqueMap
65
66 newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show)
67
68 instance IsMap UniqueMap where
69 type KeyOf UniqueMap = Unique
70
71 mapNull (UM m) = M.null m
72 mapSize (UM m) = M.size m
73 mapMember k (UM m) = M.member k m
74 mapLookup k (UM m) = M.lookup k m
75 mapFindWithDefault def k (UM m) = M.findWithDefault def k m
76
77 mapEmpty = UM M.empty
78 mapSingleton k v = UM (M.singleton k v)
79 mapInsert k v (UM m) = UM (M.insert k v m)
80 mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
81 mapDelete k (UM m) = UM (M.delete k m)
82
83 mapUnion (UM x) (UM y) = UM (M.union x y)
84 mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)
85 mapDifference (UM x) (UM y) = UM (M.difference x y)
86 mapIntersection (UM x) (UM y) = UM (M.intersection x y)
87 mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
88
89 mapMap f (UM m) = UM (M.map f m)
90 mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)
91 mapFold k z (UM m) = M.fold k z m
92 mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m
93
94 mapElems (UM m) = M.elems m
95 mapKeys (UM m) = M.keys m
96 mapToList (UM m) = M.toList m
97 mapFromList assocs = UM (M.fromList assocs)
98 mapFromListWith f assocs = UM (M.fromListWith f assocs)
99
100 ----------------------------------------------------------------
101 -- Monads
102
103 class Monad m => UniqueMonad m where
104 freshUnique :: m Unique
105
106 newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) }
107
108 instance Monad SimpleUniqueMonad where
109 return a = SUM $ \us -> (a, us)
110 m >>= k = SUM $ \us -> let (a, us') = unSUM m us in
111 unSUM (k a) us'
112
113 instance UniqueMonad SimpleUniqueMonad where
114 freshUnique = SUM $ f
115 where f (u:us) = (u, us)
116 f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list"
117
118 instance CheckpointMonad SimpleUniqueMonad where
119 type Checkpoint SimpleUniqueMonad = [Unique]
120 checkpoint = SUM $ \us -> (us, us)
121 restart us = SUM $ \_ -> ((), us)
122
123 runSimpleUniqueMonad :: SimpleUniqueMonad a -> a
124 runSimpleUniqueMonad m = fst (unSUM m allUniques)
125
126 ----------------------------------------------------------------
127
128 newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) }
129
130 instance Monad m => Monad (UniqueMonadT m) where
131 return a = UMT $ \us -> return (a, us)
132 m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' }
133
134 instance Monad m => UniqueMonad (UniqueMonadT m) where
135 freshUnique = UMT $ f
136 where f (u:us) = return (u, us)
137 f _ = error "Unique.freshUnique(UniqueMonadT): empty list"
138
139 runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a
140 runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }
141
142 allUniques :: [Unique]
143 allUniques = [1..]