{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedTuples #-}

module GHC.Types.Unique.Supply (
        -- * Main data type
        UniqSupply, -- Abstractly

        -- ** Operations on supplies
        uniqFromSupply, uniqsFromSupply, -- basic ops
        takeUniqFromSupply, uniqFromTag,

        mkSplitUniqSupply,
        splitUniqSupply, listSplitUniqSupply,

        -- * Unique supply monad and its abstraction
        UniqSM, MonadUnique(..),

        -- ** Operations on the monad
        initUs, initUs_,

        -- * Set supply strategy
        initUniqSupply
  ) where

import GHC.Prelude

import GHC.Types.Unique
import GHC.Utils.Panic.Plain

import GHC.IO

import GHC.Utils.Monad
import Control.Monad
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
import GHC.Utils.Monad.State.Strict as Strict

#include "MachDeps.h"

#if WORD_SIZE_IN_BITS != 64
#define NO_FETCH_ADD
#endif

#if defined(NO_FETCH_ADD)
import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# )
#else
import GHC.Exts( fetchAddWordAddr#, word64ToWord# )
#endif

import GHC.Exts ( Addr#, State#, Word64#, RealWorld )
import GHC.Int ( Int(..) )
import GHC.Word( Word64(..) )
import GHC.Exts( plusWord64#, int2Word#, wordToWord64# )

{-
************************************************************************
*                                                                      *
\subsection{Splittable Unique supply: @UniqSupply@}
*                                                                      *
************************************************************************
-}

{- Note [How the unique supply works]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea (due to Lennart Augustsson) is that a UniqSupply is
lazily-evaluated infinite tree.

* At each MkSplitUniqSupply node is a unique Word64, and two
  sub-trees (see data UniqSupply)

* takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
  returns the unique Word64 and one of the sub-trees

* splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
  returns the two sub-trees

* When you poke on one of the thunks, it does a foreign call
  to get a fresh Word64 from a thread-safe counter, and returns
  a fresh MkSplitUniqSupply node.  This has to be as efficient
  as possible: it should allocate only
     * The fresh node
     * A thunk for each sub-tree

Note [How unique supplies are used]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The general design (used throughout GHC) is to:

* For creating new uniques either a UniqSupply is used and threaded through
  or for monadic code a MonadUnique instance might conjure up uniques using
  `uniqFromTag`.
* Different parts of the compiler will use a UniqSupply or MonadUnique instance
  with a specific tag. This way the different parts of the compiler will
  generate uniques with different tags.

If different code shares the same tag then care has to be taken that all uniques
still get distinct numbers. Usually this is done by relying on genSym which
has *one* counter per GHC invocation that is relied on by all calls to it.
But using something like the address for pinned objects works as well and in fact is done
for fast strings.

This is important for example in the simplifier. Most passes of the simplifier use
the same tag 's'. However in some places we create a unique supply using `mkSplitUniqSupply`
and thread it through the code, while in GHC.Core.Opt.Simplify.Monad  we use the
`instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM
and `uniqFromTag` in getUniqueM.

Ultimately all these boil down to each new unique consisting of the tag and the result from
a call to `genSym`. The latter producing a distinct number for each invocation ensuring
uniques are distinct.

Note [Optimising the unique supply]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The inner loop of mkSplitUniqSupply is a function closure

     mk_supply s0 =
        case noDuplicate# s0 of { s1 ->
        case unIO genSym s1 of { (# s2, u #) ->
        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->
        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->
        (# s4, MkSplitUniqSupply (tag .|. u) x y #)
        }}}}

It's a classic example of an IO action that is captured and then called
repeatedly (see #18238 for some discussion). It mustn't allocate!  The test
perf/should_run/UniqLoop keeps track of this loop.  Watch it carefully.

We used to write it as:

     mk_supply :: IO UniqSupply
     mk_supply = unsafeInterleaveIO $
                 genSym      >>= \ u ->
                 mk_supply   >>= \ s1 ->
                 mk_supply   >>= \ s2 ->
                 return (MkSplitUniqSupply (tag .|. u) s1 s2)

and to rely on -fno-state-hack, full laziness and inlining to get the same
result. It was very brittle and required enabling -fno-state-hack globally. So
it has been rewritten using lower level constructs to explicitly state what we
want.

Note [Optimising use of unique supplies]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When it comes to having a way to generate new Uniques
there are generally three ways to deal with this:

For pure code the only good approach is to take an UniqSupply
as argument. Then  thread it through the code splitting it
for sub-passes or when creating uniques.
The code for this is about as optimized as it gets, but we can't
get around the need to allocate one `UniqSupply` for each Unique
we need.

For code in IO we can improve on this by threading only the *tag*
we are going to use for Uniques. Using `uniqFromTag` to
generate uniques as needed. This gets rid of the overhead of
allocating a new UniqSupply for each unique generated. It also avoids
frequent state updates when the Unique/Tag is part of the state in a
state monad.

For monadic code in IO which always uses the same tag we can go further
and hardcode the tag into the MonadUnique instance. On top of all the
benefits of threading the tag this *also* has the benefit of avoiding
the tag getting captured in thunks, or being passed around at runtime.
It does however come at the cost of having to use a fixed tag for all
code run in this Monad. The tag is mostly cosmetic: See Note [Uniques and tags].

NB: It's *not* an optimization to pass around the UniqSupply inside an
IORef instead of the tag. While this would avoid frequent state updates
it still requires allocating one UniqSupply per Unique. On top of some
overhead for reading/writing to/from the IORef.

All of this hinges on the assumption that UniqSupply and
uniqFromTag use the same source of distinct numbers (`genSym`) which
allows both to be used at the same time, with the same tag, while still
ensuring distinct uniques.
One might consider this fact to be an "accident". But GHC worked like this
as far back as source control history goes. It also allows the later two
optimizations to be used. So it seems safe to depend on this fact.

-}


-- | Unique Supply
--
-- A value of type 'UniqSupply' is unique, and it can
-- supply /one/ distinct 'Unique'.  Also, from the supply, one can
-- also manufacture an arbitrary number of further 'UniqueSupply' values,
-- which will be distinct from the first and from all others.
data UniqSupply
  = MkSplitUniqSupply {-# UNPACK #-} !Word64 -- make the Unique with this
                   UniqSupply UniqSupply
                                -- when split => these two supplies

mkSplitUniqSupply :: Char -> IO UniqSupply
-- ^ Create a unique supply out of thin air.
-- The "tag" (Char) supplied is mostly cosmetic, making it easier
-- to figure out where a Unique was born. See Note [Uniques and tags].
--
-- The payload part of the Uniques allocated from this UniqSupply are
-- guaranteed distinct wrt all other supplies, regardless of their "tag".
-- This is achieved by allocating the payload part from
-- a single source of Uniques, namely `genSym`, shared across
-- all UniqSupply's.

-- See Note [How the unique supply works]
-- See Note [Optimising the unique supply]
mkSplitUniqSupply :: Char -> IO UniqSupply
mkSplitUniqSupply Char
c
  = IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)

  where
     !tag :: Word64
tag = Char -> Word64
mkTag Char
c

        -- Here comes THE MAGIC: see Note [How the unique supply works]
        -- This is one of the most hammered bits in the whole compiler
        -- See Note [Optimising the unique supply]
        -- NB: Use noDuplicate# for thread-safety.
     mk_supply :: State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply State# RealWorld
s0 =
        case State# RealWorld -> State# RealWorld
forall d. State# d -> State# d
noDuplicate# State# RealWorld
s0 of { State# RealWorld
s1 ->
        case IO Word64 -> State# RealWorld -> (# State# RealWorld, Word64 #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO IO Word64
genSym State# RealWorld
s1 of { (# State# RealWorld
s2, Word64
u #) ->
        -- deferred IO computations
        case IO UniqSupply
-> State# RealWorld -> (# State# RealWorld, UniqSupply #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)) State# RealWorld
s2 of { (# State# RealWorld
s3, UniqSupply
x #) ->
        case IO UniqSupply
-> State# RealWorld -> (# State# RealWorld, UniqSupply #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO UniqSupply -> IO UniqSupply
forall a. IO a -> IO a
unsafeDupableInterleaveIO ((State# RealWorld -> (# State# RealWorld, UniqSupply #))
-> IO UniqSupply
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, UniqSupply #)
mk_supply)) State# RealWorld
s3 of { (# State# RealWorld
s4, UniqSupply
y #) ->
        (# State# RealWorld
s4, Word64 -> UniqSupply -> UniqSupply -> UniqSupply
MkSplitUniqSupply (Word64
tag Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
u) UniqSupply
x UniqSupply
y #)
        }}}}

#if defined(NO_FETCH_ADD)
-- GHC currently does not provide this operation on 32-bit platforms,
-- hence the CAS-based implementation.
fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
                    -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# = go
  where
    go ptr inc s0 =
      case readWord64OffAddr# ptr 0# s0 of
        (# s1, n0 #) ->
          case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of
            (# s2, res #)
              | 1# <- res `eqWord64#` n0 -> (# s2, n0 #)
              | otherwise -> go ptr inc s2
#else
fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld
                    -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# :: Addr#
-> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# Addr#
addr Word64#
inc State# RealWorld
s0 =
    case Addr# -> Word# -> State# RealWorld -> (# State# RealWorld, Word# #)
forall d. Addr# -> Word# -> State# d -> (# State# d, Word# #)
fetchAddWordAddr# Addr#
addr (Word64# -> Word#
word64ToWord# Word64#
inc) State# RealWorld
s0 of
      (# State# RealWorld
s1, Word#
res #) -> (# State# RealWorld
s1, Word# -> Word64#
wordToWord64# Word#
res #)
#endif

genSym :: IO Word64
genSym :: IO Word64
genSym = do
    let !mask :: Word64
mask = (Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
uNIQUE_BITS) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
    let !(Ptr Addr#
counter) = Ptr Word64
ghc_unique_counter64
    I# inc# <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
ghc_unique_inc
    let !inc = Word# -> Word64#
wordToWord64# (Int# -> Word#
int2Word# Int#
inc#)
    u <- IO $ \State# RealWorld
s1 -> case Addr#
-> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)
fetchAddWord64Addr# Addr#
counter Word64#
inc State# RealWorld
s1 of
            (# State# RealWorld
s2, Word64#
val #) ->
                let !u :: Word64
u = Word64# -> Word64
W64# (Word64#
val Word64# -> Word64# -> Word64#
`plusWord64#` Word64#
inc) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
mask
                in (# State# RealWorld
s2, Word64
u #)
#if defined(DEBUG)
    -- Uh oh! We will overflow next time a unique is requested.
    -- (Note that if the increment isn't 1 we may miss this check)
    massert (u /= mask)
#endif
    return u

foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64
foreign import ccall unsafe "&ghc_unique_inc"       ghc_unique_inc       :: Ptr Int

initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply :: Word64 -> Int -> IO ()
initUniqSupply Word64
counter Int
inc = do
    Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word64
ghc_unique_counter64 Word64
counter
    Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int
ghc_unique_inc       Int
inc

uniqFromTag :: Char -> IO Unique
uniqFromTag :: Char -> IO Unique
uniqFromTag !Char
tag
  = do { uqNum <- IO Word64
genSym
       ; return $! mkUnique tag uqNum }
{-# NOINLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it

splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
-- ^ Build two 'UniqSupply' from a single one, each of which
-- can supply its own 'Unique'.
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
-- ^ Create an infinite list of 'UniqSupply' from a single one
uniqFromSupply  :: UniqSupply -> Unique
-- ^ Obtain the 'Unique' from this particular 'UniqSupply'
uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply

splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (MkSplitUniqSupply Word64
_ UniqSupply
s1 UniqSupply
s2) = (UniqSupply
s1, UniqSupply
s2)
listSplitUniqSupply :: UniqSupply -> [UniqSupply]
listSplitUniqSupply  (MkSplitUniqSupply Word64
_ UniqSupply
s1 UniqSupply
s2) = UniqSupply
s1 UniqSupply -> [UniqSupply] -> [UniqSupply]
forall a. a -> [a] -> [a]
: UniqSupply -> [UniqSupply]
listSplitUniqSupply UniqSupply
s2

uniqFromSupply :: UniqSupply -> Unique
uniqFromSupply  (MkSplitUniqSupply Word64
n UniqSupply
_ UniqSupply
_)  = Word64 -> Unique
mkUniqueGrimily Word64
n
uniqsFromSupply :: UniqSupply -> [Unique]
uniqsFromSupply (MkSplitUniqSupply Word64
n UniqSupply
_ UniqSupply
s2) = Word64 -> Unique
mkUniqueGrimily Word64
n Unique -> [Unique] -> [Unique]
forall a. a -> [a] -> [a]
: UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
s2
takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (MkSplitUniqSupply Word64
n UniqSupply
s1 UniqSupply
_) = (Word64 -> Unique
mkUniqueGrimily Word64
n, UniqSupply
s1)

{-# INLINE splitUniqSupply #-}

{-
************************************************************************
*                                                                      *
\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
*                                                                      *
************************************************************************
-}

type UniqResult result = (# result, UniqSupply #)

pattern UniqResult :: a -> b -> (# a, b #)
pattern $mUniqResult :: forall {r} {a} {b}.
(# a, b #) -> (a -> b -> r) -> ((# #) -> r) -> r
$bUniqResult :: forall a b. a -> b -> (# a, b #)
UniqResult x y = (# x, y #)
{-# COMPLETE UniqResult #-}

-- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM :: UniqSupply -> UniqResult result }
  deriving ((forall a b. (a -> b) -> UniqSM a -> UniqSM b)
-> (forall a b. a -> UniqSM b -> UniqSM a) -> Functor UniqSM
forall a b. a -> UniqSM b -> UniqSM a
forall a b. (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> UniqSM a -> UniqSM b
fmap :: forall a b. (a -> b) -> UniqSM a -> UniqSM b
$c<$ :: forall a b. a -> UniqSM b -> UniqSM a
<$ :: forall a b. a -> UniqSM b -> UniqSM a
Functor, Functor UniqSM
Functor UniqSM =>
(forall a. a -> UniqSM a)
-> (forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b)
-> (forall a b c.
    (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM b)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM a)
-> Applicative UniqSM
forall a. a -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM b
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> UniqSM a
pure :: forall a. a -> UniqSM a
$c<*> :: forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
<*> :: forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
$cliftA2 :: forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
liftA2 :: forall a b c. (a -> b -> c) -> UniqSM a -> UniqSM b -> UniqSM c
$c*> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
*> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
$c<* :: forall a b. UniqSM a -> UniqSM b -> UniqSM a
<* :: forall a b. UniqSM a -> UniqSM b -> UniqSM a
Applicative, Applicative UniqSM
Applicative UniqSM =>
(forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b)
-> (forall a b. UniqSM a -> UniqSM b -> UniqSM b)
-> (forall a. a -> UniqSM a)
-> Monad UniqSM
forall a. a -> UniqSM a
forall a b. UniqSM a -> UniqSM b -> UniqSM b
forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
>>= :: forall a b. UniqSM a -> (a -> UniqSM b) -> UniqSM b
$c>> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
>> :: forall a b. UniqSM a -> UniqSM b -> UniqSM b
$creturn :: forall a. a -> UniqSM a
return :: forall a. a -> UniqSM a
Monad) via (Strict.State UniqSupply)

-- | Smart constructor for 'UniqSM', as described in Note [The one-shot state
-- monad trick].
mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM :: forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM UniqSupply -> UniqResult a
f = (UniqSupply -> UniqResult a) -> UniqSM a
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
USM ((UniqSupply -> UniqResult a) -> UniqSupply -> UniqResult a
forall a b. (a -> b) -> a -> b
oneShot UniqSupply -> UniqResult a
f)
{-# INLINE mkUniqSM #-}

-- TODO: try to get rid of this instance
instance MonadFail UniqSM where
    fail :: forall a. String -> UniqSM a
fail = String -> UniqSM a
forall a. HasCallStack => String -> a
panic

-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs :: forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
init_us UniqSM a
m = case UniqSM a -> UniqSupply -> UniqResult a
forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM UniqSM a
m UniqSupply
init_us of { UniqResult a
r UniqSupply
us -> (a
r, UniqSupply
us) }

-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ :: forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
init_us UniqSM a
m = case UniqSM a -> UniqSupply -> UniqResult a
forall result. UniqSM result -> UniqSupply -> UniqResult result
unUSM UniqSM a
m UniqSupply
init_us of { UniqResult a
r UniqSupply
_ -> a
r }

liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM :: forall a. UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM UniqSupply -> UniqResult a
m) UniqSupply
us0 = case UniqSupply -> UniqResult a
m UniqSupply
us0 of UniqResult a
a UniqSupply
us1 -> (a
a, UniqSupply
us1)

instance MonadFix UniqSM where
    mfix :: forall a. (a -> UniqSM a) -> UniqSM a
mfix a -> UniqSM a
m = (UniqSupply -> UniqResult a) -> UniqSM a
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> let (a
r,UniqSupply
us1) = UniqSM a -> UniqSupply -> (a, UniqSupply)
forall a. UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (a -> UniqSM a
m a
r) UniqSupply
us0 in a -> UniqSupply -> UniqResult a
forall a b. a -> b -> (# a, b #)
UniqResult a
r UniqSupply
us1)

getUs :: UniqSM UniqSupply
getUs :: UniqSM UniqSupply
getUs = (UniqSupply -> UniqResult UniqSupply) -> UniqSM UniqSupply
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of (UniqSupply
us1,UniqSupply
us2) -> UniqSupply -> UniqSupply -> UniqResult UniqSupply
forall a b. a -> b -> (# a, b #)
UniqResult UniqSupply
us1 UniqSupply
us2)

-- | A monad for generating unique identifiers
class Monad m => MonadUnique m where
    -- | Get a new UniqueSupply
    getUniqueSupplyM :: m UniqSupply
    -- | Get a new unique identifier
    getUniqueM  :: m Unique
    -- | Get an infinite list of new unique identifiers
    getUniquesM :: m [Unique]

    -- This default definition of getUniqueM, while correct, is not as
    -- efficient as it could be since it needlessly generates and throws away
    -- an extra Unique. For your instances consider providing an explicit
    -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly.
    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

getUniqueUs :: UniqSM Unique
getUniqueUs :: UniqSM Unique
getUniqueUs = (UniqSupply -> UniqResult Unique) -> UniqSM Unique
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us0 of
                           (Unique
u,UniqSupply
us1) -> Unique -> UniqSupply -> UniqResult Unique
forall a b. a -> b -> (# a, b #)
UniqResult Unique
u UniqSupply
us1)

getUniquesUs :: UniqSM [Unique]
getUniquesUs :: UniqSM [Unique]
getUniquesUs = (UniqSupply -> UniqResult [Unique]) -> UniqSM [Unique]
forall a. (UniqSupply -> UniqResult a) -> UniqSM a
mkUniqSM (\UniqSupply
us0 -> case UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us0 of
                            (UniqSupply
us1,UniqSupply
us2) -> [Unique] -> UniqSupply -> UniqResult [Unique]
forall a b. a -> b -> (# a, b #)
UniqResult (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1) UniqSupply
us2)