{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
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
data JEnv = JEnv { JEnv -> FastString
prefix :: !FastString
, JEnv -> UniqSupply
ids :: UniqSupply
}
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
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 supply <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'j'
return (initJSMState "js" 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}
newIdent :: JSM Ident
newIdent :: JSM Ident
newIdent = do env <- StateT JEnv Identity JEnv
forall (m :: * -> *) s. Monad m => StateT s m s
get
let tag = JEnv -> FastString
prefix JEnv
env
supply = JEnv -> UniqSupply
ids JEnv
env
(id,rest) = takeUniqFromSupply supply
update_stream rest
return $ mk_ident tag id
mk_ident :: FastString -> Unique -> Ident
mk_ident :: FastString -> Unique -> Ident
mk_ident FastString
t Unique
i = FastString -> Ident
name ([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)])
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})
withTag
:: FastString
-> JSM a
-> JSM a
withTag :: forall a. FastString -> JSM a -> JSM a
withTag FastString
tag JSM a
go = do
old <- (JEnv -> FastString) -> StateT JEnv Identity FastString
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets JEnv -> FastString
prefix
tag_names tag
result <- go
tag_names old
return result