{-# 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 { JEnv -> FastString
prefix :: !FastString -- ^ prefix for generated names, e.g.,
                                         -- prefix = "RTS" will generate names
                                         -- such as 'h$RTS_jUt'
                 , JEnv -> UniqSupply
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 :: forall a. JEnv -> JSM a -> a
runJSM JEnv
env JSM a
m = JSM a -> JEnv -> a
forall s a. State s a -> s -> a
evalState JSM a
m JEnv
env

-- | create a new environment using the input tag.
initJSMState :: FastString -> UniqSupply -> JEnv
initJSMState :: FastString -> UniqSupply -> JEnv
initJSMState FastString
tag UniqSupply
supply = JEnv { prefix :: FastString
prefix = FastString
tag
                               , ids :: UniqSupply
ids    = UniqSupply
supply
                               }
initJSM :: IO JEnv
initJSM :: IO JEnv
initJSM = do UniqSupply
supply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'j'
             JEnv -> IO JEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> UniqSupply -> JEnv
initJSMState FastString
"js" UniqSupply
supply)

update_stream :: UniqSupply -> JSM ()
update_stream :: UniqSupply -> JSM ()
update_stream UniqSupply
new = (JEnv -> JEnv) -> JSM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((JEnv -> JEnv) -> JSM ()) -> (JEnv -> JEnv) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JEnv
env -> JEnv
env {ids = new}

-- | generate a fresh Ident
newIdent :: JSM Ident
newIdent :: JSM Ident
newIdent = do JEnv
env <- StateT JEnv Identity JEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
              let tag :: FastString
tag    = JEnv -> FastString
prefix JEnv
env
                  supply :: UniqSupply
supply = JEnv -> UniqSupply
ids    JEnv
env
                  (Unique
id,UniqSupply
rest) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
supply
              UniqSupply -> JSM ()
update_stream UniqSupply
rest
              Ident -> JSM Ident
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Ident -> JSM Ident) -> Ident -> JSM Ident
forall a b. (a -> b) -> a -> b
$ FastString -> Unique -> Ident
mk_ident FastString
tag Unique
id

mk_ident :: FastString -> Unique -> Ident
mk_ident :: FastString -> Unique -> Ident
mk_ident FastString
t Unique
i = FastString -> Ident
global ([FastString] -> FastString
forall a. Monoid a => [a] -> a
mconcat [FastString
t, FastString
"_", String -> FastString
mkFastString (Unique -> String
forall a. Show a => a -> String
show Unique
i)])

-- | Set the tag for @Ident@s for all remaining computations.
tag_names :: FastString -> JSM ()
tag_names :: FastString -> JSM ()
tag_names FastString
tag = (JEnv -> JEnv) -> JSM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\JEnv
env -> JEnv
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 :: forall a. FastString -> JSM a -> JSM a
withTag FastString
tag JSM a
go = do
  FastString
old <- (JEnv -> FastString) -> StateT JEnv Identity FastString
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets JEnv -> FastString
prefix
  FastString -> JSM ()
tag_names FastString
tag
  a
result <- JSM a
go
  FastString -> JSM ()
tag_names FastString
old
  a -> JSM a
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result