-----------------------------------------------------------------------------
-- |
-- 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.JStg.Syntax
import GHC.JS.Ident
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
  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
  liftIO $ do
    -- no need for atomicFetchAdd as we don't use threads in G
    v <- readFastMutInt id_gen
    writeFastMutInt id_gen (v+1)
    pure v

-- | Get fresh module-local Ident of the form: h$$unit:module_uniq
freshIdent :: G Ident
freshIdent :: G Ident
freshIdent = do
  i <- G Int
freshUnique
  mod <- State.gets gsModule
  let !name = Module -> Int -> FastString
mkFreshJsSymbol Module
mod Int
i
  return (global 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
global 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 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 <- case M.lookup key 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
      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  = Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId Id
i Maybe Int
mi IdType
id_type Module
mod
      let !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)
      State.modify (\GenState
s -> GenState
s { gsIdents = cache' })
      pure ident

  -- Now update the GlobalId cache, if required

  let 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?

  when (update_global_cache) $ do
    GlobalIdCache gidc <- getGlobalIdCache
    case elemUFM ident 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 ()

  pure 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 JStgExpr
varForId :: Id -> G JStgExpr
varForId Id
i = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
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 JStgExpr
varForIdN :: Id -> Int -> G JStgExpr
varForIdN Id
i Int
n = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
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 [JStgExpr]
varsForId :: Id -> G [JStgExpr]
varsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
  Int
0 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [JStgExpr]
forall a. Monoid a => a
mempty
  Int
1 -> (JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[]) (JStgExpr -> [JStgExpr]) -> G JStgExpr -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JStgExpr
varForId Id
i
  Int
s -> (Int -> G JStgExpr) -> [Int] -> G [JStgExpr]
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 JStgExpr
varForIdN Id
i) [Int
1..Int
s]


-- | Retrieve entry variable name for the given Id
varForEntryId :: Id -> G JStgExpr
varForEntryId :: Id -> G JStgExpr
varForEntryId Id
i = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
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 JStgExpr
varForDataConEntryId :: Id -> G JStgExpr
varForDataConEntryId Id
i = JVal -> JStgExpr
ValExpr (JVal -> JStgExpr) -> (Ident -> JVal) -> Ident -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar (Ident -> JStgExpr) -> G Ident -> G JStgExpr
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 JStgExpr
varForDataConWorker :: DataCon -> G JStgExpr
varForDataConWorker DataCon
d = Id -> G JStgExpr
varForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)

-- | Declare all js vars for the id
declVarsForId :: Id -> G JStgStat
declVarsForId :: Id -> G JStgStat
declVarsForId  Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
  Int
0 -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
  Int
1 -> Ident -> JStgStat
decl (Ident -> JStgStat) -> G Ident -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
  Int
s -> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> G JStgStat) -> [Int] -> StateT GenState IO [JStgStat]
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 -> JStgStat
decl (Ident -> JStgStat) -> G Ident -> G JStgStat
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]