HsImplementation.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module FFICXX.Generate.Code.HsImplementation
  ( -- * import
    genImportInImplementation,

    -- * functions
    genHsFrontInst,
    genHsFrontInstNew,
    genHsFrontInstNonVirtual,
    genHsFrontInstStatic,
    genHsFrontInstVariables,

    -- * template member functions
    genTemplateMemberFunctions,
  )
where

import Control.Monad.Reader (Reader)
import qualified Data.List as L (foldr1)
import FFICXX.Generate.Code.Primitive
  ( accessorSignature,
    cxx2HsType,
    functionSignature,
    functionSignatureTMF,
    hsFuncXformer,
  )
import FFICXX.Generate.Name
  ( accessorName,
    aliasedFuncName,
    hsFuncName,
    hsTemplateMemberFunctionName,
    hsTemplateMemberFunctionNameTH,
    hscAccessorName,
    hscFuncName,
    subModuleName,
    typeclassName,
  )
import FFICXX.Generate.Type.Annotate (AnnotateMap)
import FFICXX.Generate.Type.Class
  ( Accessor (..),
    Class (..),
    TemplateMemberFunction (..),
    Types (..),
    isAbstractClass,
    isNewFunc,
    nonVirtualNotNewFuncs,
    staticFuncs,
    virtualFuncs,
  )
import FFICXX.Generate.Type.Module
  ( ClassImportHeader (..),
    ClassModule (..),
  )
import FFICXX.Generate.Util.GHCExactPrint
  ( app,
    bracketExp,
    con,
    cxEmpty,
    doE,
    inapp,
    instD,
    lamE,
    letE,
    listE,
    mkBind1_,
    mkBindStmt,
    mkBodyStmt,
    mkFun,
    mkFun_,
    mkImport,
    mkInstance,
    mkLetStmt,
    mkPVar,
    mkVar,
    op,
    pApp,
    pTuple,
    par,
    pbind_,
    strE,
    toLocalBinds,
    tupleE,
    tyTupleBoxed,
    tyapp,
    tycon,
    tyfun,
    tylist,
    typeBracket,
    valBinds,
  )
import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
import qualified FFICXX.Runtime.CodeGen.Cxx as R
import FFICXX.Runtime.Types (FFISafety (..))
import GHC.Hs (GhcPs)
import Language.Haskell.Syntax (HsDecl, ImportDecl)

--
-- import
--

genImportInImplementation :: ClassModule -> [ImportDecl GhcPs]
genImportInImplementation m =
  fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m

--
-- functions
--

genHsFrontInst :: Class -> Class -> [HsDecl GhcPs]
genHsFrontInst parent child
  | (not . isAbstractClass) child =
      let idecl = mkInstance cxEmpty (typeclassName parent) [cxx2HsType (Just child) SelfType] [] body
          defn f = mkBind1_ (hsFuncName child f) [] rhs
            where
              rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))
          body = map defn . virtualFuncs . class_funcs $ parent
       in [instD idecl]
  | otherwise = []

genHsFrontInstNew ::
  -- | only concrete class
  Class ->
  Reader AnnotateMap [HsDecl GhcPs]
genHsFrontInstNew c = do
  -- amap <- ask
  let fs = filter isNewFunc (class_funcs c)
  pure . flip concatMap fs $ \f ->
    let -- for the time being, let's ignore annotation.
        -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap
        -- newfuncann = mkComment 0 cann
        rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
     in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs

genHsFrontInstNonVirtual :: Class -> [HsDecl GhcPs]
genHsFrontInstNonVirtual c =
  flip concatMap nonvirtualFuncs $ \f ->
    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
     in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs
  where
    nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)

genHsFrontInstStatic :: Class -> [HsDecl GhcPs]
genHsFrontInstStatic c =
  flip concatMap (staticFuncs (class_funcs c)) $ \f ->
    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
     in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs

genHsFrontInstVariables :: Class -> [HsDecl GhcPs]
genHsFrontInstVariables c =
  flip concatMap (class_vars c) $ \v ->
    let rhs accessor =
          app
            (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1"))
            (mkVar (hscAccessorName c v accessor))
     in mkFun_ (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter)
          <> mkFun_ (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter)

--
-- Template Member Function
--

genTemplateMemberFunctions :: ClassImportHeader -> [HsDecl GhcPs]
genTemplateMemberFunctions cih =
  let c = cihClass cih
   in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c)

-- TODO: combine this with genTmplInstance
genTMFExp :: Class -> TemplateMemberFunction -> [HsDecl GhcPs]
genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts
  where
    nh = hsTemplateMemberFunctionNameTH c f
    v = mkVar
    p = mkPVar
    itps = zip ([1 ..] :: [Int]) (tmf_params f)
    tvars = map (\(i, _) -> "typ" ++ show i) itps
    nparams = length itps
    tparams
      | nparams == 1 = tycon "Type"
      | otherwise = tyTupleBoxed (replicate nparams (tycon "Type"))
    sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")]
    tvars_p
      | nparams == 1 = fmap p tvars
      | otherwise = [pTuple (fmap p tvars)]
    lit' = strE (hsTemplateMemberFunctionName c f <> "_")
    lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n")
    safety =
      case tmf_safety f of
        FFIUnsafe -> "FFIUnsafe"
        FFISafe -> "FFISafe"
        FFIInterruptible -> "FFIInterruptible"
    rhs =
      app (v "mkTFunc") $
        app (v safety) $
          let typs
                | nparams == 1 = fmap v tvars
                | otherwise = [tupleE (map v tvars)]
           in tupleE (typs ++ [v "suffix", lam, v "tyf"])
    sig' = functionSignatureTMF c f
    tassgns =
      fmap
        (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i))))
        itps
    bstmts =
      toLocalBinds True $
        valBinds
          [ mkBind1_
              "tyf"
              [mkPVar "n"]
              ( letE
                  (toLocalBinds False (valBinds tassgns))
                  (bracketExp (typeBracket sig'))
              )
          ]

genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [HsDecl GhcPs]
genTMFInstance cih f =
  mkFun_
    fname
    sig
    [p "isCprim", pTuple [p "qtyp", p "param"]]
    rhs
  where
    c = cihClass cih
    fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f
    p = mkPVar
    v = mkVar
    sig =
      tycon "IsCPrimitive"
        `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]
        `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec"))
    rhs =
      doE
        [ suffixstmt,
          qtypstmt,
          genstmt,
          foreignSrcStmt,
          mkLetStmt lststmt,
          mkBodyStmt retstmt
        ]
    suffixstmt =
      mkLetStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")]
    qtypstmt =
      mkBindStmt (p "typ") (v "qtyp")
    genstmt =
      mkBindStmt
        (p "f1")
        ( v "mkMember"
            `app` par
              ( strE (hsTemplateMemberFunctionName c f <> "_")
                  `app` v "<>"
                  `app` v "suffix"
              )
            `app` v (hsTemplateMemberFunctionNameTH c f)
            `app` v "typ"
            `app` v "suffix"
        )

    lststmt = [pbind_ (p "lst") (listE ([v "f1"]))]
    retstmt = v "pure" `app` v "lst"
    -- TODO: refactor out the following code.
    foreignSrcStmt =
      mkBodyStmt $
        (v "addModFinalizer")
          `app` par
            ( v "addForeignSource"
                `app` con "LangCxx"
                `app` par
                  ( L.foldr1
                      (\x y -> inapp x (op "++") y)
                      [ par includeStatic,
                        par includeDynamic,
                        par namespaceStr,
                        strE (hsTemplateMemberFunctionName c f),
                        strE "(",
                        v "suffix",
                        strE ")\n"
                      ]
                  )
            )
      where
        includeStatic =
          strE $
            concatMap ((<> "\n") . R.renderCMacro . R.Include) $
              [HdrName "MacroPatternMatch.h", cihSelfHeader cih]
                <> cihIncludedHPkgHeadersInCPP cih
                <> cihIncludedCPkgHeaders cih
        includeDynamic =
          letE
            ( toLocalBinds False . valBinds $
                [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param"),
                  pbind_
                    (pApp "f" [p "x"])
                    (v "renderCMacro" `app` par (con "Include" `app` v "x"))
                ]
            )
            (v "concatMap" `app` v "f" `app` v "headers")
        namespaceStr =
          letE
            ( toLocalBinds False . valBinds $
                [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param"),
                  pbind_
                    (pApp "f" [p "x"])
                    (v "renderCStmt" `app` par (con "UsingNamespace" `app` v "x"))
                ]
            )
            (v "concatMap" `app` v "f" `app` v "nss")