-----------------------------------------------------------------------------
-- |
-- 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.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

-- | Get fresh unique number
freshUnique :: G Int
freshUnique :: G Int
freshUnique = do
  FastMutInt
id_gen <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> FastMutInt
gsId
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
vforall a. Num a => a -> a -> a
+Int
1)
    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 <- 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
  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     = 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 forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ Bool -> Module -> FastString -> ByteString
mkJsSymbolBS Bool
exported Module
mod (OccName -> FastString
occNameFS (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 -> forall a. Monoid a => a
mempty
          Just Int
v  -> 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    -> 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 forall a. Monoid a => a
mempty
          else let (Char
c,Int
u) = Unique -> (Char, Int)
unpkUnique (forall a. Uniquable a => a -> Unique
getUnique Id
i)
               in forall a. Monoid a => [a] -> a
mconcat [String -> ByteString
BSC.pack [Char
'_',Char
c,Char
'_'], Int -> ByteString
intBS Int
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 = Int -> Int -> IdType -> IdKey
IdKey (Unique -> Int
getKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Uniquable a => a -> Unique
getUnique forall a b. (a -> b) -> a -> b
$ Id
i) (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 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> IdCache
gsIdents
  Ident
ident <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IdKey
key Map IdKey Ident
cache of
    Just Ident
ident -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
ident
    Maybe Ident
Nothing -> do
      Module
mod <- 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 (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert IdKey
key Ident
ident Map IdKey Ident
cache)
      forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (\GenState
s -> GenState
s { gsIdents :: IdCache
gsIdents = IdCache
cache' })
      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
&& forall a. Maybe a -> Bool
isNothing Maybe Int
mi Bool -> Bool -> Bool
&& IdType
id_type forall a. Eq a => a -> a -> Bool
== IdType
IdPlain
      -- fixme also allow caching entries for lifting?

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
update_global_cache) forall a b. (a -> b) -> a -> b
$ do
    GlobalIdCache UniqFM Ident (IdKey, Id)
gidc <- G GlobalIdCache
getGlobalIdCache
    case 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 forall a b. (a -> b) -> a -> b
$ UniqFM Ident (IdKey, Id) -> GlobalIdCache
GlobalIdCache (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  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  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 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 (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  Int
1 -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
  Int
s -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 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 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 = forall a. ToJExpr a => a -> JExpr
toJExpr 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 = forall a. ToJExpr a => a -> JExpr
toJExpr 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  Int
1 -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JExpr
varForId Id
i
  Int
s -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 = forall a. ToJExpr a => a -> JExpr
toJExpr 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  Int
1 -> Ident -> JStat
decl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
  Int
s -> forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
n -> Ident -> JStat
decl 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]