2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 UniqSupply, -- Abstractly
18 uniqFromSupply, uniqsFromSupply, -- basic ops
20 UniqSM, -- type: unique supply monad
22 lazyThenUs, lazyMapUs,
27 splitUniqSupply, listSplitUniqSupply,
30 getUniqueUs, getUs, returnUs, thenUs, mapUs
33 #include "HsVersions.h"
40 import Control.Monad.Fix
41 #if __GLASGOW_HASKELL__ >= 607
42 import GHC.IOBase (unsafeDupableInterleaveIO)
44 import System.IO.Unsafe ( unsafeInterleaveIO )
45 unsafeDupableInterleaveIO :: IO a -> IO a
46 unsafeDupableInterleaveIO = unsafeInterleaveIO
52 %************************************************************************
54 \subsection{Splittable Unique supply: @UniqSupply@}
56 %************************************************************************
58 A value of type @UniqSupply@ is unique, and it can
59 supply {\em one} distinct @Unique@. Also, from the supply, one can
60 also manufacture an arbitrary number of further @UniqueSupplies@,
61 which will be distinct from the first and from all others.
65 = MkSplitUniqSupply FastInt -- make the Unique with this
67 -- when split => these two supplies
71 mkSplitUniqSupply :: Char -> IO UniqSupply
73 splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
74 listSplitUniqSupply :: UniqSupply -> [UniqSupply] -- Infinite
75 uniqFromSupply :: UniqSupply -> Unique
76 uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
81 = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of
83 -- here comes THE MAGIC:
85 -- This is one of the most hammered bits in the whole compiler
87 = unsafeDupableInterleaveIO (
88 genSymZh >>= \ u_ -> case iUnbox u_ of { u -> (
91 return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2)
96 foreign import ccall unsafe "genSymZh" genSymZh :: IO Int
98 splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
99 listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
103 uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n)
104 uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2
107 %************************************************************************
109 \subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
111 %************************************************************************
114 newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
116 instance Monad UniqSM where
121 instance Functor UniqSM where
122 fmap f (USM x) = USM (\us -> case x us of
123 (r, us') -> (f r, us'))
125 instance Applicative UniqSM where
127 (USM f) <*> (USM x) = USM $ \us -> case f us of
128 (ff, us') -> case x us' of
129 (xx, us'') -> (ff xx, us'')
131 -- the initUs function also returns the final UniqSupply; initUs_ drops it
132 initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
133 initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) }
135 initUs_ :: UniqSupply -> UniqSM a -> a
136 initUs_ init_us m = case unUSM m init_us of { (r,us) -> r }
138 {-# INLINE thenUs #-}
139 {-# INLINE lazyThenUs #-}
140 {-# INLINE returnUs #-}
141 {-# INLINE splitUniqSupply #-}
144 @thenUs@ is where we split the @UniqSupply@.
146 instance MonadFix UniqSM where
147 mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
149 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
150 thenUs (USM expr) cont
151 = USM (\us -> case (expr us) of
152 (result, us') -> unUSM (cont result) us')
154 lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
155 lazyThenUs (USM expr) cont
156 = USM (\us -> let (result, us') = expr us in unUSM (cont result) us')
158 thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
159 thenUs_ (USM expr) (USM cont)
160 = USM (\us -> case (expr us) of { (_, us') -> cont us' })
162 returnUs :: a -> UniqSM a
163 returnUs result = USM (\us -> (result, us))
165 withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a
166 withUs f = USM (\us -> f us) -- Ha ha!
168 getUs :: UniqSM UniqSupply
169 getUs = USM (\us -> splitUniqSupply us)
171 -- | A monad for generating unique identifiers
172 class Monad m => MonadUnique m where
173 -- | Get a new UniqueSupply
174 getUniqueSupplyM :: m UniqSupply
175 -- | Get a new unique identifier
176 getUniqueM :: m Unique
177 -- | Get an infinite list of new unique identifiers
178 getUniquesM :: m [Unique]
180 getUniqueM = liftM uniqFromSupply getUniqueSupplyM
181 getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
183 instance MonadUnique UniqSM where
184 getUniqueSupplyM = USM (\us -> splitUniqSupply us)
185 getUniqueM = getUniqueUs
186 getUniquesM = getUniquesUs
188 getUniqueUs :: UniqSM Unique
189 getUniqueUs = USM (\us -> case splitUniqSupply us of
190 (us1,us2) -> (uniqFromSupply us1, us2))
192 getUniquesUs :: UniqSM [Unique]
193 getUniquesUs = USM (\us -> case splitUniqSupply us of
194 (us1,us2) -> (uniqsFromSupply us1, us2))
196 mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
197 mapUs f [] = returnUs []
199 = f x `thenUs` \ r ->
200 mapUs f xs `thenUs` \ rs ->
205 {-# -- SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-}
206 {-# -- SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-}
207 {-# -- SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-}
209 lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
210 lazyMapUs f [] = returnUs []
212 = f x `lazyThenUs` \ r ->
213 lazyMapUs f xs `lazyThenUs` \ rs ->