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