    {-# 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))