module UniqSupply (
UniqSupply,
uniqFromSupply, uniqsFromSupply,
takeUniqFromSupply,
mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply,
splitUniqSupply3, splitUniqSupply4,
UniqSM, MonadUnique(..), liftUs,
initUs, initUs_,
lazyThenUs, lazyMapUs,
getUniqueSupplyM3,
initUniqSupply
) where
import GhcPrelude
import Unique
import Panic (panic)
import GHC.IO
import MonadUtils
import Control.Monad
import Data.Bits
import Data.Char
import Control.Monad.Fail
#include "Unique.h"
data UniqSupply
= MkSplitUniqSupply !Int
UniqSupply UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
uniqFromSupply :: UniqSupply -> Unique
uniqsFromSupply :: UniqSupply -> [Unique]
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
mkSplitUniqSupply c
= case ord c `shiftL` uNIQUE_BITS of
mask -> let
mk_supply
= unsafeInterleaveIO (
genSym >>= \ u ->
mk_supply >>= \ s1 ->
mk_supply >>= \ s2 ->
return (MkSplitUniqSupply (mask .|. u) s1 s2)
)
in
mk_supply
foreign import ccall unsafe "genSym" genSym :: IO Int
foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO ()
splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
splitUniqSupply3 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply)
splitUniqSupply3 us = (us1, us2, us3)
where
(us1, us') = splitUniqSupply us
(us2, us3) = splitUniqSupply us'
splitUniqSupply4 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply, UniqSupply)
splitUniqSupply4 us = (us1, us2, us3, us4)
where
(us1, us2, us') = splitUniqSupply3 us
(us3, us4) = splitUniqSupply us'
newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
instance Monad UniqSM where
(>>=) = thenUs
(>>) = (*>)
instance Functor UniqSM where
fmap f (USM x) = USM (\us -> case x us of
(# r, us' #) -> (# f r, us' #))
instance Applicative UniqSM where
pure = returnUs
(USM f) <*> (USM x) = USM $ \us -> case f us of
(# ff, us' #) -> case x us' of
(# xx, us'' #) -> (# ff xx, us'' #)
(*>) = thenUs_
instance MonadFail UniqSM where
fail = panic
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')
instance MonadFix UniqSM where
mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #))
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs (USM expr) cont
= USM (\us -> case (expr us) of
(# result, us' #) -> unUSM (cont result) us')
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs expr cont
= USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us')
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ (USM expr) (USM cont)
= USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })
returnUs :: a -> UniqSM a
returnUs result = USM (\us -> (# result, us #))
getUs :: UniqSM UniqSupply
getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))
class Monad m => MonadUnique m where
getUniqueSupplyM :: m UniqSupply
getUniqueM :: m Unique
getUniquesM :: m [Unique]
getUniqueM = liftM uniqFromSupply getUniqueSupplyM
getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
instance MonadUnique UniqSM where
getUniqueSupplyM = getUs
getUniqueM = getUniqueUs
getUniquesM = getUniquesUs
getUniqueSupplyM3 :: MonadUnique m => m (UniqSupply, UniqSupply, UniqSupply)
getUniqueSupplyM3 = liftM3 (,,) getUniqueSupplyM getUniqueSupplyM getUniqueSupplyM
liftUs :: MonadUnique m => UniqSM a -> m a
liftUs m = getUniqueSupplyM >>= return . flip initUs_ m
getUniqueUs :: UniqSM Unique
getUniqueUs = USM (\us -> case takeUniqFromSupply us of
(u,us') -> (# u, us' #))
getUniquesUs :: UniqSM [Unique]
getUniquesUs = USM (\us -> case splitUniqSupply us of
(us1,us2) -> (# uniqsFromSupply us1, us2 #))
lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
lazyMapUs _ [] = returnUs []
lazyMapUs f (x:xs)
= f x `lazyThenUs` \ r ->
lazyMapUs f xs `lazyThenUs` \ rs ->
returnUs (r:rs)