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

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.StgToJS.DataCon
    -- 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
    --
    --  Code generation of data constructors
    -----------------------------------------------------------------------------

    module GHC.StgToJS.DataCon
      ( genCon
      , allocCon
      , allocUnboxedCon
      , allocDynamicE
      , allocDynamic
      )
    where

    import GHC.Prelude

    import GHC.JS.JStg.Syntax
    import GHC.JS.Ident
    import GHC.JS.Make
    import GHC.JS.Transform

    import GHC.StgToJS.Closure
    import GHC.StgToJS.ExprCtx
    import GHC.StgToJS.Types
    import GHC.StgToJS.Monad
    import GHC.StgToJS.Profiling
    import GHC.StgToJS.Utils
    import GHC.StgToJS.Ids

    import GHC.Core.DataCon

    import GHC.Types.CostCentre

    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import Data.Maybe

    -- | Generate a data constructor. Special handling for unboxed tuples
    genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
    genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
    genCon ExprCtx
    ctx DataCon
    con [JStgExpr]
    args
      | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    con
      = JStgStat -> G JStgStat
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
    forall a b. (a -> b) -> a -> b
    $ ExprCtx -> [JStgExpr] -> JStgStat
    assignToExprCtx ExprCtx
    ctx [JStgExpr]
    args

      | [Var Ident
    ctxi] <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (TypedExpr -> [JStgExpr]
    typex_expr) (ExprCtx -> [TypedExpr]
    ctxTarget ExprCtx
    ctx)
      = Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
    allocCon Ident
    ctxi DataCon
    con CostCentreStack
    currentCCS [JStgExpr]
    args

      | [JStgExpr]
    xs <- (TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap TypedExpr -> [JStgExpr]
    typex_expr (ExprCtx -> [TypedExpr]
    ctxTarget ExprCtx
    ctx)
      = String -> SDoc -> G JStgStat
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "genCon: unhandled DataCon" ((DataCon, [JExpr], [JExpr]) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (DataCon
    con
                                                  , (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map JStgExpr -> JExpr
    jStgExprToJS [JStgExpr]
    args
                                                  , (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map JStgExpr -> JExpr
    jStgExprToJS [JStgExpr]
    xs
                                                  ))

    -- | Allocate a data constructor. Allocate in this context means bind the data
    -- constructor to 'to'
    allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
    allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
    allocCon Ident
    to DataCon
    con CostCentreStack
    cc [JStgExpr]
    xs
      | DataCon -> Bool
    isBoolDataCon DataCon
    con Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxableCon DataCon
    con =
          JStgStat -> G JStgStat
    forall a. a -> StateT GenState IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JStgStat -> G JStgStat) -> JStgStat -> G JStgStat
    forall a b. (a -> b) -> a -> b
    $ JStgExpr -> AOp -> JStgExpr -> JStgStat
    AssignStat (Ident -> JStgExpr
    Var Ident
    to) AOp
    AssignOp (DataCon -> [JStgExpr] -> JStgExpr
    allocUnboxedCon DataCon
    con [JStgExpr]
    xs)
    {-  | null xs = do
          i <- varForId (dataConWorkId con)
          return (assignj to i) -}
      | Bool
    otherwise = do
          e <- DataCon -> G JStgExpr
    varForDataConWorker DataCon
    con
          cs <- getSettings
          prof <- profiling
          ccsJ <- if prof then ccsVarJ cc else return Nothing
          return $ allocDynamic cs False to e xs ccsJ

    -- | Allocate an unboxed data constructor. If we have a bool we calculate the
    -- right value. If not then we expect a singleton list and unbox by converting
    -- ''C x' to 'x'. NB. This function may panic.
    allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
    allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
    allocUnboxedCon DataCon
    con = \case
      []
        | DataCon -> Bool
    isBoolDataCon DataCon
    con Bool -> Bool -> Bool
    && DataCon -> Int
    dataConTag DataCon
    con Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1 -> JStgExpr
    false_
        | DataCon -> Bool
    isBoolDataCon DataCon
    con Bool -> Bool -> Bool
    && DataCon -> Int
    dataConTag DataCon
    con Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    2 -> JStgExpr
    true_
      [JStgExpr
    x]
        | DataCon -> Bool
    isUnboxableCon DataCon
    con -> JStgExpr
    x
      [JStgExpr]
    xs -> String -> SDoc -> JStgExpr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "allocUnboxedCon: not an unboxed constructor" ((DataCon, [JExpr]) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (DataCon
    con, (JStgExpr -> JExpr) -> [JStgExpr] -> [JExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map JStgExpr -> JExpr
    jStgExprToJS [JStgExpr]
    xs))

    -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
    allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig
                  -> JStgExpr
                  -> [JStgExpr]
                  -> Maybe JStgExpr
                  -> JStgExpr
    allocDynamicE :: Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
    allocDynamicE  Bool
    inline_alloc JStgExpr
    entry [JStgExpr]
    free Maybe JStgExpr
    cc
      | Bool
    inline_alloc Bool -> Bool -> Bool
    || [JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    free Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    jsClosureCount
        = Closure -> JStgExpr
    newClosure (Closure -> JStgExpr) -> Closure -> JStgExpr
    forall a b. (a -> b) -> a -> b
    $ JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure
    mkClosure JStgExpr
    entry [JStgExpr]
    free JStgExpr
    zero_ Maybe JStgExpr
    cc
      | Bool
    otherwise = JStgExpr -> [JStgExpr] -> JStgExpr
    ApplExpr JStgExpr
    allocFun (JStgExpr
    entry JStgExpr -> [JStgExpr] -> [JStgExpr]
    forall a. a -> [a] -> [a]
    : [JStgExpr]
    free [JStgExpr] -> [JStgExpr] -> [JStgExpr]
    forall a. [a] -> [a] -> [a]
    ++ Maybe JStgExpr -> [JStgExpr]
    forall a. Maybe a -> [a]
    maybeToList Maybe JStgExpr
    cc)
      where
        allocFun :: JStgExpr
    allocFun = Int -> JStgExpr
    allocClsA ([JStgExpr] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [JStgExpr]
    free)

    -- | Allocate a dynamic object
    allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat
    allocDynamic :: StgToJSConfig
    -> Bool
    -> Ident
    -> JStgExpr
    -> [JStgExpr]
    -> Maybe JStgExpr
    -> JStgStat
    allocDynamic StgToJSConfig
    s Bool
    need_decl Ident
    to JStgExpr
    entry [JStgExpr]
    free Maybe JStgExpr
    cc
      | Bool
    need_decl = Ident -> Maybe JStgExpr -> JStgStat
    DeclStat Ident
    to (JStgExpr -> Maybe JStgExpr
    forall a. a -> Maybe a
    Just JStgExpr
    value)
      | Bool
    otherwise = JStgExpr -> AOp -> JStgExpr -> JStgStat
    AssignStat (Ident -> JStgExpr
    Var Ident
    to) AOp
    AssignOp JStgExpr
    value
        where
          value :: JStgExpr
    value = Bool -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgExpr
    allocDynamicE (StgToJSConfig -> Bool
    csInlineAlloc StgToJSConfig
    s) JStgExpr
    entry [JStgExpr]
    free Maybe JStgExpr
    cc