module GHC.StgToJS.Ids
( freshUnique
, freshIdent
, makeIdentForId
, cachedIdentForId
, identForId
, identForIdN
, identsForId
, identForEntryId
, identForDataConEntryId
, identForDataConWorker
, varForId
, varForIdN
, varsForId
, varForEntryId
, varForDataConEntryId
, varForDataConWorker
, declVarsForId
)
where
import GHC.Prelude
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Symbols
import GHC.JS.Syntax
import GHC.JS.Make
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Data.FastMutInt
import Control.Monad
import Control.Monad.IO.Class
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Map as M
import Data.Maybe
import qualified Data.ByteString.Char8 as BSC
freshUnique :: G Int
freshUnique :: G Int
freshUnique = do
FastMutInt
id_gen <- (GenState -> FastMutInt) -> StateT GenState IO FastMutInt
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> FastMutInt
gsId
IO Int -> G Int
forall a. IO a -> StateT GenState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> G Int) -> IO Int -> G Int
forall a b. (a -> b) -> a -> b
$ do
Int
v <- FastMutInt -> IO Int
readFastMutInt FastMutInt
id_gen
FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
id_gen (Int
vInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
v
freshIdent :: G Ident
freshIdent :: G Ident
freshIdent = do
Int
i <- G Int
freshUnique
Module
mod <- (GenState -> Module) -> StateT GenState IO Module
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> Module
gsModule
let !name :: FastString
name = Module -> Int -> FastString
mkFreshJsSymbol Module
mod Int
i
Ident -> G Ident
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Ident
TxtI FastString
name)
makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId Id
i Maybe Int
num IdType
id_type Module
current_module = FastString -> Ident
TxtI FastString
ident
where
exported :: Bool
exported = Id -> Bool
isExportedId Id
i
name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
i
mod :: Module
mod
| Bool
exported
, Just Module
m <- Name -> Maybe Module
nameModule_maybe Name
name
= Module
m
| Bool
otherwise
= Module
current_module
!ident :: FastString
ident = ByteString -> FastString
mkFastStringByteString (ByteString -> FastString) -> ByteString -> FastString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
[ Bool -> Module -> FastString -> ByteString
mkJsSymbolBS Bool
exported Module
mod (OccName -> FastString
occNameFS (Name -> OccName
nameOccName Name
name))
, case Maybe Int
num of
Maybe Int
Nothing -> ByteString
forall a. Monoid a => a
mempty
Just Int
v -> [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [String -> ByteString
BSC.pack String
"_", Int -> ByteString
intBS Int
v]
, case IdType
id_type of
IdType
IdPlain -> ByteString
forall a. Monoid a => a
mempty
IdType
IdEntry -> String -> ByteString
BSC.pack String
"_e"
IdType
IdConEntry -> String -> ByteString
BSC.pack String
"_con_e"
, if Bool
exported
then ByteString
forall a. Monoid a => a
mempty
else let (Char
c,Int
u) = Unique -> (Char, Int)
unpkUnique (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i)
in [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [String -> ByteString
BSC.pack [Char
'_',Char
c,Char
'_'], Int -> ByteString
intBS Int
u]
]
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
mi IdType
id_type = do
let !key :: IdKey
key = Int -> Int -> IdType -> IdKey
IdKey (Unique -> Int
getKey (Unique -> Int) -> (Id -> Unique) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique (Id -> Int) -> Id -> Int
forall a b. (a -> b) -> a -> b
$ Id
i) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mi) IdType
id_type
IdCache Map IdKey Ident
cache <- (GenState -> IdCache) -> StateT GenState IO IdCache
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> IdCache
gsIdents
Ident
ident <- case IdKey -> Map IdKey Ident -> Maybe Ident
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IdKey
key Map IdKey Ident
cache of
Just Ident
ident -> Ident -> G Ident
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
ident
Maybe Ident
Nothing -> do
Module
mod <- (GenState -> Module) -> StateT GenState IO Module
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> Module
gsModule
let !ident :: Ident
ident = Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId Id
i Maybe Int
mi IdType
id_type Module
mod
let !cache' :: IdCache
cache' = Map IdKey Ident -> IdCache
IdCache (IdKey -> Ident -> Map IdKey Ident -> Map IdKey Ident
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert IdKey
key Ident
ident Map IdKey Ident
cache)
(GenState -> GenState) -> StateT GenState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\GenState
s -> GenState
s { gsIdents = cache' })
Ident -> G Ident
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
ident
let update_global_cache :: Bool
update_global_cache = Id -> Bool
isGlobalId Id
i Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
mi Bool -> Bool -> Bool
&& IdType
id_type IdType -> IdType -> Bool
forall a. Eq a => a -> a -> Bool
== IdType
IdPlain
Bool -> StateT GenState IO () -> StateT GenState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
update_global_cache) (StateT GenState IO () -> StateT GenState IO ())
-> StateT GenState IO () -> StateT GenState IO ()
forall a b. (a -> b) -> a -> b
$ do
GlobalIdCache UniqFM Ident (IdKey, Id)
gidc <- G GlobalIdCache
getGlobalIdCache
case Ident -> UniqFM Ident (IdKey, Id) -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Ident
ident UniqFM Ident (IdKey, Id)
gidc of
Bool
False -> GlobalIdCache -> StateT GenState IO ()
setGlobalIdCache (GlobalIdCache -> StateT GenState IO ())
-> GlobalIdCache -> StateT GenState IO ()
forall a b. (a -> b) -> a -> b
$ UniqFM Ident (IdKey, Id) -> GlobalIdCache
GlobalIdCache (UniqFM Ident (IdKey, Id)
-> Ident -> (IdKey, Id) -> UniqFM Ident (IdKey, Id)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Ident (IdKey, Id)
gidc Ident
ident (IdKey
key, Id
i))
Bool
True -> () -> StateT GenState IO ()
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Ident -> G Ident
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
ident
identForId :: Id -> G Ident
identForId :: Id -> G Ident
identForId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdPlain
identForIdN :: Id -> Int -> G Ident
identForIdN :: Id -> Int -> G Ident
identForIdN Id
i Int
n = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n) IdType
IdPlain
identsForId :: Id -> G [Ident]
identsForId :: Id -> G [Ident]
identsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> [Ident] -> G [Ident]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Ident]
forall a. Monoid a => a
mempty
Int
1 -> (Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[]) (Ident -> [Ident]) -> G Ident -> G [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
Int
s -> (Int -> G Ident) -> [Int] -> G [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> Int -> G Ident
identForIdN Id
i) [Int
1..Int
s]
identForEntryId :: Id -> G Ident
identForEntryId :: Id -> G Ident
identForEntryId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdEntry
identForDataConEntryId :: Id -> G Ident
identForDataConEntryId :: Id -> G Ident
identForDataConEntryId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdConEntry
varForId :: Id -> G JExpr
varForId :: Id -> G JExpr
varForId Id
i = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> G Ident -> G JExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
varForIdN :: Id -> Int -> G JExpr
varForIdN :: Id -> Int -> G JExpr
varForIdN Id
i Int
n = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> G Ident -> G JExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> G Ident
identForIdN Id
i Int
n
varsForId :: Id -> G [JExpr]
varsForId :: Id -> G [JExpr]
varsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> [JExpr] -> G [JExpr]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [JExpr]
forall a. Monoid a => a
mempty
Int
1 -> (JExpr -> [JExpr] -> [JExpr]
forall a. a -> [a] -> [a]
:[]) (JExpr -> [JExpr]) -> G JExpr -> G [JExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JExpr
varForId Id
i
Int
s -> (Int -> G JExpr) -> [Int] -> G [JExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> Int -> G JExpr
varForIdN Id
i) [Int
1..Int
s]
varForEntryId :: Id -> G JExpr
varForEntryId :: Id -> G JExpr
varForEntryId Id
i = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> G Ident -> G JExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForEntryId Id
i
varForDataConEntryId :: Id -> G JExpr
varForDataConEntryId :: Id -> G JExpr
varForDataConEntryId Id
i = JVal -> JExpr
ValExpr (JVal -> JExpr) -> (Ident -> JVal) -> Ident -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar (Ident -> JExpr) -> G Ident -> G JExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForDataConEntryId Id
i
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker DataCon
d = Id -> G Ident
identForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)
varForDataConWorker :: DataCon -> G JExpr
varForDataConWorker :: DataCon -> G JExpr
varForDataConWorker DataCon
d = Id -> G JExpr
varForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)
declVarsForId :: Id -> G JStat
declVarsForId :: Id -> G JStat
declVarsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
Int
1 -> Ident -> JStat
decl (Ident -> JStat) -> G Ident -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
Int
s -> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> StateT GenState IO [JStat] -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> G JStat) -> [Int] -> StateT GenState IO [JStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
n -> Ident -> JStat
decl (Ident -> JStat) -> G Ident -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> G Ident
identForIdN Id
i Int
n) [Int
1..Int
s]