content: {-# LANGUAGE DerivingStrategies         #-}
  {-# LANGUAGE OverloadedStrings          #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  GHC.JS.JStg.Monad
  -- Copyright   :  (c) The University of Glasgow 2001
  -- License     :  BSD-style (see the file LICENSE)
  --
  -- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
  --                Luite Stegeman <luite.stegeman@iohk.io>
  --                Sylvain Henry  <sylvain.henry@iohk.io>
  --                Josh Meredith  <josh.meredith@iohk.io>
  -- Stability   :  experimental
  --
  --
  -- * Domain and Purpose
  --
  --     GHC.JS.JStg.Monad defines the computational environment for the eDSL that
  --     we use to write the JS Backend's RTS. Its purpose is to ensure unique
  --     identifiers are generated throughout the backend and that we can use the
  --     host language to ensure references are not mixed.
  --
  -- * Strategy
  --
  --     The monad is a straightforward state monad which holds an environment
  --     holds a pointer to a prefix to tag identifiers with and an infinite
  --     stream of identifiers.
  --
  -- * Usage
  --
  --     One should almost never need to directly use the functions in this
  --     module. Instead one should opt to use the combinators in 'GHC.JS.Make',
  --     the sole exception to this is the @withTag@ function which is used to
  --     change the prefix of identifiers for a given computation. For example,
  --     the rts uses this function to tag all identifiers generated by the RTS
  --     code as RTS_N, where N is some unique.
  -----------------------------------------------------------------------------
  module GHC.JS.JStg.Monad
    ( runJSM
    , JSM
    , withTag
    , newIdent
    , initJSM
    ) where
  
  import Prelude
  
  import GHC.JS.Ident
  
  import GHC.Types.Unique
  import GHC.Types.Unique.Supply
  import Control.Monad.Trans.State.Strict
  import GHC.Data.FastString
  
  --------------------------------------------------------------------------------
  --                            JSM Monad
  --------------------------------------------------------------------------------
  
  -- | Environment for the JSM Monad. We maintain the prefix of each ident in the
  -- environment to allow consumers to tag idents with a new prefix. See @withTag@
  data JEnv = JEnv { prefix :: !FastString -- ^ prefix for generated names, e.g.,
                                           -- prefix = "RTS" will generate names
                                           -- such as 'h$RTS_jUt'
                   , ids    :: UniqSupply  -- ^ The supply of uniques for names
                                           -- generated by the JSM monad.
                   }
  
  type JSM a = State JEnv a
  
  runJSM :: JEnv -> JSM a -> a
  runJSM env m = evalState m env
  
  -- | create a new environment using the input tag.
  initJSMState :: FastString -> UniqSupply -> JEnv
  initJSMState tag supply = JEnv { prefix = tag
                                 , ids    = supply
                                 }
  initJSM :: IO JEnv
  initJSM = do supply <- mkSplitUniqSupply 'j'
               return (initJSMState "js" supply)
  
  update_stream :: UniqSupply -> JSM ()
  update_stream new = modify' $ \env -> env {ids = new}
  
  -- | generate a fresh Ident
  newIdent :: JSM Ident
  newIdent = do env <- get
                let tag    = prefix env
                    supply = ids    env
                    (id,rest) = takeUniqFromSupply supply
                update_stream rest
                return  $ mk_ident tag id
  
  mk_ident :: FastString -> Unique -> Ident
  mk_ident t i = name (mconcat [t, "_", mkFastString (show i)])
  
  -- | Set the tag for @Ident@s for all remaining computations.
  tag_names :: FastString -> JSM ()
  tag_names tag = modify' (\env -> env {prefix = tag})
  
  -- | tag the name generater with a prefix for the monadic action.
  withTag
    :: FastString -- ^ new name to tag with
    -> JSM a      -- ^ action to run with new tags
    -> JSM a      -- ^ result
  withTag tag go = do
    old <- gets prefix
    tag_names tag
    result <- go
    tag_names old
    return result
  