#if !defined(GHC_LOADED_INTO_GHCI)
#endif
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 PlainPanic (panic)
import GHC.IO
import MonadUtils
import Control.Monad
import Data.Bits
import Data.Char
import Control.Monad.Fail as 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'
#if !defined(GHC_LOADED_INTO_GHCI)
type UniqResult result = (# result, UniqSupply #)
pattern UniqResult :: a -> b -> (# a, b #)
pattern UniqResult x y = (# x, y #)
#else
data UniqResult result = UniqResult !result !UniqSupply
#endif
newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
instance Monad UniqSM where
(>>=) = thenUs
(>>) = (*>)
instance Functor UniqSM where
fmap f (USM x) = USM (\us0 -> case x us0 of
UniqResult r us1 -> UniqResult (f r) us1)
instance Applicative UniqSM where
pure = returnUs
(USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
UniqResult ff us1 -> case x us1 of
UniqResult xx us2 -> UniqResult (ff xx) us2
(*>) = thenUs_
instance Fail.MonadFail UniqSM where
fail = panic
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
instance MonadFix UniqSM where
mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs (USM expr) cont
= USM (\us0 -> case (expr us0) of
UniqResult result us1 -> unUSM (cont result) us1)
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs expr cont
= USM (\us0 -> let (result, us1) = liftUSM expr us0 in unUSM (cont result) us1)
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ (USM expr) (USM cont)
= USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
returnUs :: a -> UniqSM a
returnUs result = USM (\us -> UniqResult result us)
getUs :: UniqSM UniqSupply
getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult 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 (\us0 -> case takeUniqFromSupply us0 of
(u,us1) -> UniqResult u us1)
getUniquesUs :: UniqSM [Unique]
getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of
(us1,us2) -> UniqResult (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)