{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module GHC.StgToJS.Heap
  ( closureType
  , entryClosureType
  , isObject
  , isThunk
  , isThunk'
  , isBlackhole
  , isFun
  , isFun'
  , isPap
  , isPap'
  , isCon
  , isCon'
  , conTag
  , conTag'
  , closureEntry
  , closureMeta
  , closureField1
  , closureField2
  , closureCC
  , funArity
  , funArity'
  , papArity
  , funOrPapArity
  -- * Field names
  , closureEntry_
  , closureMeta_
  , closureCC_
  , closureField1_
  , closureField2_
  -- * Javascript Type literals
  , jTyObject
  )
where

import GHC.Prelude

import GHC.JS.JStg.Syntax
import GHC.JS.Make
import GHC.StgToJS.Types
import GHC.Data.FastString

closureEntry_ :: FastString
closureEntry_ :: FastString
closureEntry_ = FastString
"f"

closureField1_ :: FastString
closureField1_ :: FastString
closureField1_ = FastString
"d1"

closureField2_ :: FastString
closureField2_ :: FastString
closureField2_ = FastString
"d2"

closureMeta_ :: FastString
closureMeta_ :: FastString
closureMeta_ = FastString
"m"

closureCC_ :: FastString
closureCC_ :: FastString
closureCC_ = FastString
"cc"

entryClosureType_ :: FastString
entryClosureType_ :: FastString
entryClosureType_ = FastString
"t"

entryConTag_ :: FastString
entryConTag_ :: FastString
entryConTag_ = FastString
"a"

entryFunArity_ :: FastString
entryFunArity_ :: FastString
entryFunArity_ = FastString
"a"

jTyObject :: JStgExpr
jTyObject :: JStgExpr
jTyObject = FastString -> JStgExpr
jString FastString
"object"

closureType :: JStgExpr -> JStgExpr
closureType :: JStgExpr -> JStgExpr
closureType = JStgExpr -> JStgExpr
entryClosureType (JStgExpr -> JStgExpr)
-> (JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> JStgExpr
closureEntry

entryClosureType :: JStgExpr -> JStgExpr
entryClosureType :: JStgExpr -> JStgExpr
entryClosureType JStgExpr
f = JStgExpr
f JStgExpr -> FastString -> JStgExpr
.^ FastString
entryClosureType_

isObject :: JStgExpr -> JStgExpr
isObject :: JStgExpr -> JStgExpr
isObject JStgExpr
c = JStgExpr -> JStgExpr
typeof JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. FastString -> JStgExpr
String FastString
"object"

isThunk :: JStgExpr -> JStgExpr
isThunk :: JStgExpr -> JStgExpr
isThunk JStgExpr
c = JStgExpr -> JStgExpr
closureType JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Thunk

isThunk' :: JStgExpr -> JStgExpr
isThunk' :: JStgExpr -> JStgExpr
isThunk' JStgExpr
f = JStgExpr -> JStgExpr
entryClosureType JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Thunk

isBlackhole :: JStgExpr -> JStgExpr
isBlackhole :: JStgExpr -> JStgExpr
isBlackhole JStgExpr
c = JStgExpr -> JStgExpr
closureType JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Blackhole

isFun :: JStgExpr -> JStgExpr
isFun :: JStgExpr -> JStgExpr
isFun JStgExpr
c = JStgExpr -> JStgExpr
closureType JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun

isFun' :: JStgExpr -> JStgExpr
isFun' :: JStgExpr -> JStgExpr
isFun' JStgExpr
f = JStgExpr -> JStgExpr
entryClosureType JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Fun

isPap :: JStgExpr -> JStgExpr
isPap :: JStgExpr -> JStgExpr
isPap JStgExpr
c = JStgExpr -> JStgExpr
closureType JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap

isPap' :: JStgExpr -> JStgExpr
isPap' :: JStgExpr -> JStgExpr
isPap' JStgExpr
f = JStgExpr -> JStgExpr
entryClosureType JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Pap

isCon :: JStgExpr -> JStgExpr
isCon :: JStgExpr -> JStgExpr
isCon JStgExpr
c = JStgExpr -> JStgExpr
closureType JStgExpr
c JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con

isCon' :: JStgExpr -> JStgExpr
isCon' :: JStgExpr -> JStgExpr
isCon' JStgExpr
f = JStgExpr -> JStgExpr
entryClosureType JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.===. ClosureType -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr ClosureType
Con

conTag :: JStgExpr -> JStgExpr
conTag :: JStgExpr -> JStgExpr
conTag = JStgExpr -> JStgExpr
conTag' (JStgExpr -> JStgExpr)
-> (JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> JStgExpr
closureEntry

conTag' :: JStgExpr -> JStgExpr
conTag' :: JStgExpr -> JStgExpr
conTag' JStgExpr
f = JStgExpr
f JStgExpr -> FastString -> JStgExpr
.^ FastString
entryConTag_

-- | Get closure entry function
closureEntry :: JStgExpr -> JStgExpr
closureEntry :: JStgExpr -> JStgExpr
closureEntry JStgExpr
p = JStgExpr
p JStgExpr -> FastString -> JStgExpr
.^ FastString
closureEntry_

-- | Get closure metadata
closureMeta :: JStgExpr -> JStgExpr
closureMeta :: JStgExpr -> JStgExpr
closureMeta JStgExpr
p = JStgExpr
p JStgExpr -> FastString -> JStgExpr
.^ FastString
closureMeta_

-- | Get closure cost-center
closureCC :: JStgExpr -> JStgExpr
closureCC :: JStgExpr -> JStgExpr
closureCC JStgExpr
p = JStgExpr
p JStgExpr -> FastString -> JStgExpr
.^ FastString
closureCC_

-- | Get closure extra field 1
closureField1 :: JStgExpr -> JStgExpr
closureField1 :: JStgExpr -> JStgExpr
closureField1 JStgExpr
p = JStgExpr
p JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_

-- | Get closure extra field 2
closureField2 :: JStgExpr -> JStgExpr
closureField2 :: JStgExpr -> JStgExpr
closureField2 JStgExpr
p = JStgExpr
p JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_

-- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
funArity :: JStgExpr -> JStgExpr
funArity :: JStgExpr -> JStgExpr
funArity = JStgExpr -> JStgExpr
funArity' (JStgExpr -> JStgExpr)
-> (JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JStgExpr -> JStgExpr
closureEntry

-- function arity with raw reference to the entry
funArity' :: JStgExpr -> JStgExpr
funArity' :: JStgExpr -> JStgExpr
funArity' JStgExpr
f = JStgExpr
f JStgExpr -> FastString -> JStgExpr
.^ FastString
entryFunArity_

-- arity of a partial application
papArity :: JStgExpr -> JStgExpr
papArity :: JStgExpr -> JStgExpr
papArity JStgExpr
cp = JStgExpr -> JStgExpr
closureField1 (JStgExpr -> JStgExpr
closureField2 JStgExpr
cp)

funOrPapArity
  :: JStgExpr       -- ^ heap object
  -> Maybe JStgExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice)
  -> JStgExpr       -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments)
funOrPapArity :: JStgExpr -> Maybe JStgExpr -> JStgExpr
funOrPapArity JStgExpr
c = \case
  Maybe JStgExpr
Nothing -> ((JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
IfExpr (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
isFun JStgExpr
c))) (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
funArity JStgExpr
c)))
             (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
papArity JStgExpr
c))
  Just JStgExpr
f  -> ((JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
IfExpr (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
isFun' JStgExpr
f))) (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
funArity' JStgExpr
f)))
             (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (JStgExpr -> JStgExpr
papArity JStgExpr
c))