-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Ids
-- 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
--
--  Module to deal with JS identifiers
-----------------------------------------------------------------------------

module GHC.StgToJS.Ids
  ( freshUnique
  , freshIdent
  , makeIdentForId
  , cachedIdentForId
  -- * Helpers for Idents
  , identForId
  , identForIdN
  , identsForId
  , identForEntryId
  , identForDataConEntryId
  , identForDataConWorker
  -- * Helpers for variables
  , varForId
  , varForIdN
  , varsForId
  , varForEntryId
  , varForDataConEntryId
  , varForDataConWorker
  , declVarsForId
  )
where

import GHC.Prelude

import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Utils
import GHC.StgToJS.Symbols

import GHC.JS.Unsat.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

-- | Get fresh unique number
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
    -- no need for atomicFetchAdd as we don't use threads in G
    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

-- | Get fresh local Ident of the form: h$$unit:module_uniq
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)


-- | Generate unique Ident for the given ID (uncached!)
--
-- The ident has the following forms:
--
--    global Id: h$unit:module.name[_num][_type_suffix]
--    local Id: h$$unit:module.name[_num][_type_suffix]_uniq
--
-- Note that the string is z-encoded except for "_" delimiters.
--
-- Optional "_type_suffix" can be:
--  - "_e" for IdEntry
--  - "_con_e" for IdConEntry
--
-- Optional "_num" is passed as an argument to this function. It is used for
-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#,
-- Int64#), Addr#, StablePtr#, unboxed tuples, etc.
--
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
occNameMangledFS (Name -> OccName
nameOccName Name
name))

        -------------
        -- suffixes

        -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.)
      , 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]

        -- suffix for entry and constructor entry
      , 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"

        -- unique suffix for non-exported Ids
      , if Bool
exported
          then ByteString
forall a. Monoid a => a
mempty
          else let (Char
c,Word64
u) = Unique -> (Char, Word64)
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
'_'], Word64 -> ByteString
word64BS Word64
u]
      ]

-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make
-- a new one with 'makeIdentForId' and cache it.
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
mi IdType
id_type = do

  -- compute key
  let !key :: IdKey
key = Word64 -> Int -> IdType -> IdKey
IdKey (Unique -> Word64
getKey (Unique -> Word64) -> (Id -> Unique) -> Id -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique (Id -> Word64) -> Id -> Word64
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

  -- lookup Ident in the Ident cache
  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

  -- Now update the GlobalId cache, if required

  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
      -- fixme also allow caching entries for lifting?

  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

-- | Retrieve default Ident for the given Id
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

-- | Retrieve default Ident for the given Id with sub index
--
-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS
-- var, hence we use the sub index to identify each subpart / JS variable.
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

-- | Retrieve all the idents for the given Id.
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]


-- | Retrieve entry Ident for the given Id
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

-- | Retrieve datacon entry Ident for the given Id
--
-- Different name than the datacon wrapper.
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


-- | Retrieve default variable name for the given Id
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

-- | Retrieve default variable name for the given Id with sub index
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

-- | Retrieve all the JS vars for the given Id
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]


-- | Retrieve entry variable name for the given Id
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

-- | Retrieve datacon entry variable name for the given Id
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


-- | Retrieve datacon worker entry variable name for the given datacon
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker DataCon
d = Id -> G Ident
identForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)

-- | Retrieve datacon worker entry variable name for the given datacon
varForDataConWorker :: DataCon -> G JExpr
varForDataConWorker :: DataCon -> G JExpr
varForDataConWorker DataCon
d = Id -> G JExpr
varForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)

-- | Declare all js vars for the id
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]