Monad.hs

{-# 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