{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module FFICXX.Generate.Code.HsTemplate where

import qualified Data.List as L (foldr1)
import FFICXX.Generate.Code.Cpp
  ( genTLTmplFunCpp,
    genTmplClassCpp,
    genTmplFunCpp,
    genTmplVarCpp,
  )
import FFICXX.Generate.Code.HsCast (castBody)
import FFICXX.Generate.Code.Primitive
  ( convertCpp2HS,
    convertCpp2HS4Tmpl,
    functionSignatureT,
    functionSignatureTMF,
    functionSignatureTT,
    tmplAccessorToTFun,
  )
import FFICXX.Generate.Dependency (calculateDependency)
import FFICXX.Generate.Name
  ( ffiTmplFuncName,
    hsTemplateClassName,
    hsTemplateMemberFunctionName,
    hsTemplateMemberFunctionNameTH,
    hsTmplFuncName,
    hsTmplFuncNameTH,
    subModuleName,
    tmplAccessorName,
    typeclassNameT,
  )
import FFICXX.Generate.Type.Class
  ( Accessor (Getter, Setter),
    Arg (..),
    Class (..),
    TLTemplate (..),
    TemplateClass (..),
    TemplateFunction (..),
    TemplateMemberFunction (..),
    Types (Void),
    Variable (..),
  )
import FFICXX.Generate.Type.Module
  ( ClassImportHeader (..),
    TemplateClassImportHeader (..),
    TemplateClassSubmoduleType (..),
    TopLevelImportHeader (..),
  )
import FFICXX.Generate.Util (firstUpper)
import FFICXX.Generate.Util.HaskellSrcExts
  ( bracketExp,
    clsDecl,
    con,
    conDecl,
    cxEmpty,
    generator,
    inapp,
    insDecl,
    insType,
    match,
    mkBind1,
    mkClass,
    mkData,
    mkFun,
    mkFunSig,
    mkImport,
    mkInstance,
    mkNewtype,
    mkPVar,
    mkTBind,
    mkTVar,
    mkVar,
    op,
    parenSplice,
    pbind_,
    qualConDecl,
    qualifier,
    tyPtr,
    tySplice,
    tyapp,
    tycon,
    tyfun,
    tylist,
    typeBracket,
  )
import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
import qualified FFICXX.Runtime.CodeGen.Cxx as R
import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim))
import Language.Haskell.Exts.Build
  ( app,
    binds,
    caseE,
    doE,
    lamE,
    letE,
    letStmt,
    listE,
    name,
    pApp,
    pTuple,
    paren,
    qualStmt,
    strE,
    tuple,
    wildcard,
  )
import Language.Haskell.Exts.Syntax (Boxed (Boxed), Decl (..), ImportDecl (..), Type (TyTuple))

------------------------------
-- Template member function --
------------------------------

genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()]
genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()]
genTemplateMemberFunctions ClassImportHeader
cih =
  let c :: Class
c = ClassImportHeader -> Class
cihClass ClassImportHeader
cih
   in (TemplateMemberFunction -> [Decl ()])
-> [TemplateMemberFunction] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TemplateMemberFunction
f -> Class -> TemplateMemberFunction -> [Decl ()]
genTMFExp Class
c TemplateMemberFunction
f [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> TemplateMemberFunction -> [Decl ()]
genTMFInstance ClassImportHeader
cih TemplateMemberFunction
f) (Class -> [TemplateMemberFunction]
class_tmpl_funcs Class
c)

-- TODO: combine this with genTmplInstance
genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]
genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]
genTMFExp Class
c TemplateMemberFunction
f = String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun String
nh Type ()
sig ([Pat ()]
tvars_p [Pat ()] -> [Pat ()] -> [Pat ()]
forall a. [a] -> [a] -> [a]
++ [String -> Pat ()
p String
"suffix"]) Exp ()
rhs (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just Binds ()
bstmts)
  where
    nh :: String
nh = Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionNameTH Class
c TemplateMemberFunction
f
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    itps :: [(Int, String)]
itps = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) (TemplateMemberFunction -> [String]
tmf_params TemplateMemberFunction
f)
    tvars :: [String]
tvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    nparams :: Int
nparams = [(Int, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
itps
    tparams :: Type ()
tparams = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String -> Type ()
tycon String
"Type" else () -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed (Int -> Type () -> [Type ()]
forall a. Int -> a -> [a]
replicate Int
nparams (String -> Type ()
tycon String
"Type"))
    sig :: Type ()
sig = (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun [Type ()
tparams, String -> Type ()
tycon String
"String", Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"Q") (String -> Type ()
tycon String
"Exp")]
    tvars_p :: [Pat ()]
tvars_p = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars else [[Pat ()] -> Pat ()
pTuple ((String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars)]
    lit' :: Exp ()
lit' = String -> Exp ()
strE (Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_")
    lam :: Exp ()
lam = [Pat ()] -> Exp () -> Exp ()
lamE [String -> Pat ()
p String
"n"] (Exp ()
lit' Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"<>" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"n")
    rhs :: Exp ()
rhs =
      Exp () -> Exp () -> Exp ()
app (String -> Exp ()
v String
"mkTFunc") (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
        let typs :: [Exp ()]
typs = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars else [[Exp ()] -> Exp ()
tuple ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)]
         in [Exp ()] -> Exp ()
tuple ([Exp ()]
typs [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. [a] -> [a] -> [a]
++ [String -> Exp ()
v String
"suffix", Exp ()
lam, String -> Exp ()
v String
"tyf"])
    sig' :: Type ()
sig' = Class -> TemplateMemberFunction -> Type ()
functionSignatureTMF Class
c TemplateMemberFunction
f
    tassgns :: [Decl ()]
tassgns = ((Int, String) -> Decl ()) -> [(Int, String)] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
tp) -> Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
tp) (String -> Exp ()
v String
"pure" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v (String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)))) [(Int, String)]
itps
    bstmts :: Binds ()
bstmts =
      [Decl ()] -> Binds ()
binds
        [ String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1
            String
"tyf"
            [String -> Pat ()
mkPVar String
"n"]
            ( [Decl ()] -> Exp () -> Exp ()
letE
                [Decl ()]
tassgns
                (Bracket () -> Exp ()
bracketExp (Type () -> Bracket ()
typeBracket Type ()
sig'))
            )
            Maybe (Binds ())
forall a. Maybe a
Nothing
        ]

genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()]
genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()]
genTMFInstance ClassImportHeader
cih TemplateMemberFunction
f =
  String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun
    String
fname
    Type ()
sig
    [String -> Pat ()
p String
"isCprim", [Pat ()] -> Pat ()
pTuple [String -> Pat ()
p String
"qtyp", String -> Pat ()
p String
"param"]]
    Exp ()
rhs
    Maybe (Binds ())
forall a. Maybe a
Nothing
  where
    c :: Class
c = ClassImportHeader -> Class
cihClass ClassImportHeader
cih
    fname :: String
fname = String
"genInstanceFor_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    sig :: Type ()
sig =
      String -> Type ()
tycon String
"IsCPrimitive"
        Type () -> Type () -> Type ()
`tyfun` () -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed [String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` String -> Type ()
tycon String
"Type", String -> Type ()
tycon String
"TemplateParamInfo"]
        Type () -> Type () -> Type ()
`tyfun` (String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` Type () -> Type ()
tylist (String -> Type ()
tycon String
"Dec"))
    rhs :: Exp ()
rhs = [Stmt ()] -> Exp ()
doE [Stmt ()
suffixstmt, Stmt ()
qtypstmt, Stmt ()
genstmt, Stmt ()
foreignSrcStmt, [Decl ()] -> Stmt ()
letStmt [Decl ()]
lststmt, Exp () -> Stmt ()
qualStmt Exp ()
retstmt]
    suffixstmt :: Stmt ()
suffixstmt = [Decl ()] -> Stmt ()
letStmt [Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"suffix") (String -> Exp ()
v String
"tpinfoSuffix" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"param")]
    qtypstmt :: Stmt ()
qtypstmt = Pat () -> Exp () -> Stmt ()
generator (String -> Pat ()
p String
"typ") (String -> Exp ()
v String
"qtyp")
    genstmt :: Stmt ()
genstmt =
      Pat () -> Exp () -> Stmt ()
generator
        (String -> Pat ()
p String
"f1")
        ( String -> Exp ()
v String
"mkMember"
            Exp () -> Exp () -> Exp ()
`app` ( String -> Exp ()
strE (Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_")
                      Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"<>"
                      Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"suffix"
                  )
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v (Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionNameTH Class
c TemplateMemberFunction
f)
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"typ"
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"suffix"
        )
    lststmt :: [Decl ()]
lststmt = [Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"lst") ([Exp ()] -> Exp ()
listE ([String -> Exp ()
v String
"f1"]))]
    retstmt :: Exp ()
retstmt = String -> Exp ()
v String
"pure" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"lst"
    -- TODO: refactor out the following code.
    foreignSrcStmt :: Stmt ()
foreignSrcStmt =
      Exp () -> Stmt ()
qualifier (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$
        (String -> Exp ()
v String
"addModFinalizer")
          Exp () -> Exp () -> Exp ()
`app` ( String -> Exp ()
v String
"addForeignSource"
                    Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
con String
"LangCxx"
                    Exp () -> Exp () -> Exp ()
`app` ( (Exp () -> Exp () -> Exp ()) -> [Exp ()] -> Exp ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
L.foldr1
                              (\Exp ()
x Exp ()
y -> Exp () -> QOp () -> Exp () -> Exp ()
inapp Exp ()
x (String -> QOp ()
op String
"++") Exp ()
y)
                              [ Exp ()
includeStatic,
                                Exp ()
includeDynamic,
                                Exp ()
namespaceStr,
                                String -> Exp ()
strE (Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f),
                                String -> Exp ()
strE String
"(",
                                String -> Exp ()
v String
"suffix",
                                String -> Exp ()
strE String
")\n"
                              ]
                          )
                )
      where
        includeStatic :: Exp ()
includeStatic =
          String -> Exp ()
strE (String -> Exp ()) -> String -> Exp ()
forall a b. (a -> b) -> a -> b
$
            (HeaderName -> String) -> [HeaderName] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") (String -> String)
-> (HeaderName -> String) -> HeaderName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CMacro Identity -> String
R.renderCMacro (CMacro Identity -> String)
-> (HeaderName -> CMacro Identity) -> HeaderName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include) ([HeaderName] -> String) -> [HeaderName] -> String
forall a b. (a -> b) -> a -> b
$
              [String -> HeaderName
HdrName String
"MacroPatternMatch.h", ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
cih]
                [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> [HeaderName]
cihIncludedHPkgHeadersInCPP ClassImportHeader
cih
                [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> [HeaderName]
cihIncludedCPkgHeaders ClassImportHeader
cih
        includeDynamic :: Exp ()
includeDynamic =
          [Decl ()] -> Exp () -> Exp ()
letE
            [ Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"headers") (String -> Exp ()
v String
"tpinfoCxxHeaders" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"param"),
              Pat () -> Exp () -> Decl ()
pbind_
                (Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
"f") [String -> Pat ()
p String
"x"])
                (String -> Exp ()
v String
"renderCMacro" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
con String
"Include" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x"))
            ]
            (String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"f" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"headers")
        namespaceStr :: Exp ()
namespaceStr =
          [Decl ()] -> Exp () -> Exp ()
letE
            [ Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"nss") (String -> Exp ()
v String
"tpinfoCxxNamespaces" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"param"),
              Pat () -> Exp () -> Decl ()
pbind_
                (Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
"f") [String -> Pat ()
p String
"x"])
                (String -> Exp ()
v String
"renderCStmt" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
con String
"UsingNamespace" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x"))
            ]
            (String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"f" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"nss")

--------------------
-- Template Class --
--------------------

genImportInTemplate :: TemplateClass -> [ImportDecl ()]
genImportInTemplate :: TemplateClass -> [ImportDecl ()]
genImportInTemplate TemplateClass
t0 =
  (Either
   (TemplateClassSubmoduleType, TemplateClass)
   (ClassSubmoduleType, Class)
 -> ImportDecl ())
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
-> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ImportDecl ()
mkImport (String -> ImportDecl ())
-> (Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)
    -> String)
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
-> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> String
subModuleName) ([Either
    (TemplateClassSubmoduleType, TemplateClass)
    (ClassSubmoduleType, Class)]
 -> [ImportDecl ()])
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
-> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
calculateDependency (Either
   (TemplateClassSubmoduleType, TemplateClass)
   (ClassSubmoduleType, Class)
 -> [Either
       (TemplateClassSubmoduleType, TemplateClass)
       (ClassSubmoduleType, Class)])
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
forall a b. (a -> b) -> a -> b
$ (TemplateClassSubmoduleType, TemplateClass)
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
forall a b. a -> Either a b
Left (TemplateClassSubmoduleType
TCSTTemplate, TemplateClass
t0)

-- |
genTmplInterface :: TemplateClass -> [Decl ()]
genTmplInterface :: TemplateClass -> [Decl ()]
genTmplInterface TemplateClass
t =
  [ String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkData String
rname ((String -> TyVarBind ()) -> [String] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> TyVarBind ()
mkTBind [String]
tps) [] Maybe (Deriving ())
forall a. Maybe a
Nothing,
    String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkNewtype
      String
hname
      ((String -> TyVarBind ()) -> [String] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> TyVarBind ()
mkTBind [String]
tps)
      [Maybe [TyVarBind ()]
-> Maybe (Context ()) -> ConDecl () -> QualConDecl ()
qualConDecl Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (String -> [Type ()] -> ConDecl ()
conDecl String
hname [Type () -> Type () -> Type ()
tyapp Type ()
tyPtr Type ()
rawtype])]
      Maybe (Deriving ())
forall a. Maybe a
Nothing,
    Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()
mkClass Context ()
cxEmpty (TemplateClass -> String
typeclassNameT TemplateClass
t) ((String -> TyVarBind ()) -> [String] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> TyVarBind ()
mkTBind [String]
tps) [ClassDecl ()]
methods,
    Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
cxEmpty String
"FPtr" [Type ()
hightype] [InstDecl ()]
fptrbody,
    Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
cxEmpty String
"Castable" [Type ()
hightype, Type () -> Type () -> Type ()
tyapp Type ()
tyPtr Type ()
rawtype] [InstDecl ()]
castBody
  ]
  where
    (String
hname, String
rname) = TemplateClass -> (String, String)
hsTemplateClassName TemplateClass
t
    tps :: [String]
tps = TemplateClass -> [String]
tclass_params TemplateClass
t
    fs :: [TemplateFunction]
fs = TemplateClass -> [TemplateFunction]
tclass_funcs TemplateClass
t
    vfs :: [Variable]
vfs = TemplateClass -> [Variable]
tclass_vars TemplateClass
t
    rawtype :: Type ()
rawtype = (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
rname Type () -> [Type ()] -> [Type ()]
forall a. a -> [a] -> [a]
: (String -> Type ()) -> [String] -> [Type ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Type ()
mkTVar [String]
tps)
    hightype :: Type ()
hightype = (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
hname Type () -> [Type ()] -> [Type ()]
forall a. a -> [a] -> [a]
: (String -> Type ()) -> [String] -> [Type ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Type ()
mkTVar [String]
tps)
    sigdecl :: TemplateFunction -> Decl ()
sigdecl TemplateFunction
f = String -> Type () -> Decl ()
mkFunSig (TemplateClass -> TemplateFunction -> String
hsTmplFuncName TemplateClass
t TemplateFunction
f) (TemplateClass -> TemplateFunction -> Type ()
functionSignatureT TemplateClass
t TemplateFunction
f)
    sigdeclV :: Variable -> [Decl ()]
sigdeclV Variable
vf =
      let f_g :: TemplateFunction
f_g = Variable -> Accessor -> TemplateFunction
tmplAccessorToTFun Variable
vf Accessor
Getter
          f_s :: TemplateFunction
f_s = Variable -> Accessor -> TemplateFunction
tmplAccessorToTFun Variable
vf Accessor
Setter
       in [TemplateFunction -> Decl ()
sigdecl TemplateFunction
f_g, TemplateFunction -> Decl ()
sigdecl TemplateFunction
f_s]
    methods :: [ClassDecl ()]
methods = (TemplateFunction -> ClassDecl ())
-> [TemplateFunction] -> [ClassDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (Decl () -> ClassDecl ()
clsDecl (Decl () -> ClassDecl ())
-> (TemplateFunction -> Decl ())
-> TemplateFunction
-> ClassDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateFunction -> Decl ()
sigdecl) [TemplateFunction]
fs [ClassDecl ()] -> [ClassDecl ()] -> [ClassDecl ()]
forall a. [a] -> [a] -> [a]
++ ((Decl () -> ClassDecl ()) -> [Decl ()] -> [ClassDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map Decl () -> ClassDecl ()
clsDecl ([Decl ()] -> [ClassDecl ()])
-> ([Variable] -> [Decl ()]) -> [Variable] -> [ClassDecl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Variable -> [Decl ()]) -> [Variable] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Variable -> [Decl ()]
sigdeclV) [Variable]
vfs
    fptrbody :: [InstDecl ()]
fptrbody =
      [ Type () -> Type () -> InstDecl ()
insType (Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"Raw") Type ()
hightype) Type ()
rawtype,
        Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"get_fptr" [Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
hname) [String -> Pat ()
mkPVar String
"ptr"]] (String -> Exp ()
mkVar String
"ptr") Maybe (Binds ())
forall a. Maybe a
Nothing),
        Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"cast_fptr_to_obj" [] (String -> Exp ()
con String
hname) Maybe (Binds ())
forall a. Maybe a
Nothing)
      ]

-- |
genImportInTH :: TemplateClass -> [ImportDecl ()]
genImportInTH :: TemplateClass -> [ImportDecl ()]
genImportInTH TemplateClass
t0 =
  (Either
   (TemplateClassSubmoduleType, TemplateClass)
   (ClassSubmoduleType, Class)
 -> ImportDecl ())
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
-> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ImportDecl ()
mkImport (String -> ImportDecl ())
-> (Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)
    -> String)
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
-> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> String
subModuleName) ([Either
    (TemplateClassSubmoduleType, TemplateClass)
    (ClassSubmoduleType, Class)]
 -> [ImportDecl ()])
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
-> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
calculateDependency (Either
   (TemplateClassSubmoduleType, TemplateClass)
   (ClassSubmoduleType, Class)
 -> [Either
       (TemplateClassSubmoduleType, TemplateClass)
       (ClassSubmoduleType, Class)])
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
forall a b. (a -> b) -> a -> b
$ (TemplateClassSubmoduleType, TemplateClass)
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
forall a b. a -> Either a b
Left (TemplateClassSubmoduleType
TCSTTH, TemplateClass
t0)

-- |
genTmplImplementation :: TemplateClass -> [Decl ()]
genTmplImplementation :: TemplateClass -> [Decl ()]
genTmplImplementation TemplateClass
t =
  (TemplateFunction -> [Decl ()]) -> [TemplateFunction] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TemplateFunction -> [Decl ()]
gen (TemplateClass -> [TemplateFunction]
tclass_funcs TemplateClass
t) [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ (Variable -> [Decl ()]) -> [Variable] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Variable -> [Decl ()]
genV (TemplateClass -> [Variable]
tclass_vars TemplateClass
t)
  where
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    itps :: [(Int, String)]
itps = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) (TemplateClass -> [String]
tclass_params TemplateClass
t)
    tvars :: [String]
tvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    nparams :: Int
nparams = [(Int, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
itps
    tparams :: Type ()
tparams = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String -> Type ()
tycon String
"Type" else () -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed (Int -> Type () -> [Type ()]
forall a. Int -> a -> [a]
replicate Int
nparams (String -> Type ()
tycon String
"Type"))
    sig :: Type ()
sig = (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun [Type ()
tparams, String -> Type ()
tycon String
"String", Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"Q") (String -> Type ()
tycon String
"Exp")]
    tvars_p :: [Pat ()]
tvars_p = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars else [[Pat ()] -> Pat ()
pTuple ((String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars)]
    prefix :: String
prefix = TemplateClass -> String
tclass_name TemplateClass
t
    gen :: TemplateFunction -> [Decl ()]
gen TemplateFunction
f = String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun String
nh Type ()
sig ([Pat ()]
tvars_p [Pat ()] -> [Pat ()] -> [Pat ()]
forall a. [a] -> [a] -> [a]
++ [String -> Pat ()
p String
"suffix"]) Exp ()
rhs (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just Binds ()
bstmts)
      where
        nh :: String
nh = TemplateClass -> TemplateFunction -> String
hsTmplFuncNameTH TemplateClass
t TemplateFunction
f
        nc :: String
nc = TemplateFunction -> String
ffiTmplFuncName TemplateFunction
f
        lit' :: Exp ()
lit' = String -> Exp ()
strE (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
nc)
        lam :: Exp ()
lam = [Pat ()] -> Exp () -> Exp ()
lamE [String -> Pat ()
p String
"n"] (Exp ()
lit' Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"<>" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"n")
        rhs :: Exp ()
rhs =
          Exp () -> Exp () -> Exp ()
app (String -> Exp ()
v String
"mkTFunc") (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
            let typs :: [Exp ()]
typs = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars else [[Exp ()] -> Exp ()
tuple ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)]
             in [Exp ()] -> Exp ()
tuple ([Exp ()]
typs [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. [a] -> [a] -> [a]
++ [String -> Exp ()
v String
"suffix", Exp ()
lam, String -> Exp ()
v String
"tyf"])
        sig' :: Type ()
sig' = TemplateClass -> TemplateFunction -> Type ()
functionSignatureTT TemplateClass
t TemplateFunction
f
        tassgns :: [Decl ()]
tassgns = ((Int, String) -> Decl ()) -> [(Int, String)] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
tp) -> Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
tp) (String -> Exp ()
v String
"pure" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v (String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)))) [(Int, String)]
itps
        bstmts :: Binds ()
bstmts =
          [Decl ()] -> Binds ()
binds
            [ String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1
                String
"tyf"
                [Pat ()
wildcard]
                ( [Decl ()] -> Exp () -> Exp ()
letE
                    [Decl ()]
tassgns
                    (Bracket () -> Exp ()
bracketExp (Type () -> Bracket ()
typeBracket Type ()
sig'))
                )
                Maybe (Binds ())
forall a. Maybe a
Nothing
            ]
    genV :: Variable -> [Decl ()]
genV Variable
vf =
      let f_g :: TemplateFunction
f_g = Variable -> Accessor -> TemplateFunction
tmplAccessorToTFun Variable
vf Accessor
Getter
          f_s :: TemplateFunction
f_s = Variable -> Accessor -> TemplateFunction
tmplAccessorToTFun Variable
vf Accessor
Setter
       in TemplateFunction -> [Decl ()]
gen TemplateFunction
f_g [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ TemplateFunction -> [Decl ()]
gen TemplateFunction
f_s

-- |
genTmplInstance ::
  TemplateClassImportHeader ->
  [Decl ()]
genTmplInstance :: TemplateClassImportHeader -> [Decl ()]
genTmplInstance TemplateClassImportHeader
tcih =
  String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun
    String
fname
    Type ()
sig
    (String -> Pat ()
p String
"isCprim" Pat () -> [Pat ()] -> [Pat ()]
forall a. a -> [a] -> [a]
: (String -> String -> Pat ()) -> [String] -> [String] -> [Pat ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
x String
y -> [Pat ()] -> Pat ()
pTuple [String -> Pat ()
p String
x, String -> Pat ()
p String
y]) [String]
qtvars [String]
pvars)
    Exp ()
rhs
    Maybe (Binds ())
forall a. Maybe a
Nothing
  where
    t :: TemplateClass
t = TemplateClassImportHeader -> TemplateClass
tcihTClass TemplateClassImportHeader
tcih
    fs :: [TemplateFunction]
fs = TemplateClass -> [TemplateFunction]
tclass_funcs TemplateClass
t
    vfs :: [Variable]
vfs = TemplateClass -> [Variable]
tclass_vars TemplateClass
t
    tname :: String
tname = TemplateClass -> String
tclass_name TemplateClass
t
    fname :: String
fname = String
"gen" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"InstanceFor"
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    itps :: [(Int, String)]
itps = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) (TemplateClass -> [String]
tclass_params TemplateClass
t)
    tvars :: [String]
tvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    qtvars :: [String]
qtvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"qtyp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    pvars :: [String]
pvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"param" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    nparams :: Int
nparams = [(Int, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
itps
    typs_v :: Exp ()
typs_v = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String -> Exp ()
v ([String]
tvars [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) else [Exp ()] -> Exp ()
tuple ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)
    params_l :: Exp ()
params_l = [Exp ()] -> Exp ()
listE ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
pvars)
    sig :: Type ()
sig =
      (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun ([Type ()] -> Type ()) -> [Type ()] -> Type ()
forall a b. (a -> b) -> a -> b
$
        [String -> Type ()
tycon String
"IsCPrimitive"]
          [Type ()] -> [Type ()] -> [Type ()]
forall a. [a] -> [a] -> [a]
++ Int -> Type () -> [Type ()]
forall a. Int -> a -> [a]
replicate
            Int
nparams
            (() -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed [String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` String -> Type ()
tycon String
"Type", String -> Type ()
tycon String
"TemplateParamInfo"])
          [Type ()] -> [Type ()] -> [Type ()]
forall a. [a] -> [a] -> [a]
++ [String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` Type () -> Type ()
tylist (String -> Type ()
tycon String
"Dec")]
    nfs :: [(Int, TemplateFunction)]
nfs = [Int] -> [TemplateFunction] -> [(Int, TemplateFunction)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) [TemplateFunction]
fs
    nvfs :: [(Int, Variable)]
nvfs = [Int] -> [Variable] -> [(Int, Variable)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) [Variable]
vfs
    --------------------------
    -- final RHS expression --
    --------------------------
    rhs :: Exp ()
rhs =
      [Stmt ()] -> Exp ()
doE
        ( [Stmt ()
paramsstmt, Stmt ()
suffixstmt]
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> [ Pat () -> Exp () -> Stmt ()
generator (String -> Pat ()
p String
"callmod_") (String -> Exp ()
v String
"fmap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"loc_module" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"location")),
                 [Decl ()] -> Stmt ()
letStmt
                   [ Pat () -> Exp () -> Decl ()
pbind_
                       (String -> Pat ()
p String
"callmod")
                       (String -> Exp ()
v String
"dot2_" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"callmod_")
                   ]
               ]
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> ((String, String) -> Stmt ()) -> [(String, String)] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> Stmt ()
genqtypstmt ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
tvars [String]
qtvars)
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> ((Int, TemplateFunction) -> Stmt ())
-> [(Int, TemplateFunction)] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TemplateFunction) -> Stmt ()
forall {a}. Show a => (a, TemplateFunction) -> Stmt ()
genstmt [(Int, TemplateFunction)]
nfs
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> ((Int, Variable) -> [Stmt ()]) -> [(Int, Variable)] -> [Stmt ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Variable) -> [Stmt ()]
forall {a}. (Show a, Num a) => (a, Variable) -> [Stmt ()]
genvarstmt [(Int, Variable)]
nvfs
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> [Stmt ()
foreignSrcStmt, [Decl ()] -> Stmt ()
letStmt [Decl ()]
lststmt, Exp () -> Stmt ()
qualStmt Exp ()
retstmt]
        )
    --------------------------
    paramsstmt :: Stmt ()
paramsstmt =
      [Decl ()] -> Stmt ()
letStmt
        [ Pat () -> Exp () -> Decl ()
pbind_
            (String -> Pat ()
p String
"params")
            (String -> Exp ()
v String
"map" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"tpinfoSuffix") Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l)
        ]
    suffixstmt :: Stmt ()
suffixstmt =
      [Decl ()] -> Stmt ()
letStmt
        [ Pat () -> Exp () -> Decl ()
pbind_
            (String -> Pat ()
p String
"suffix")
            ( String -> Exp ()
v String
"concatMap"
                Exp () -> Exp () -> Exp ()
`app` ([Pat ()] -> Exp () -> Exp ()
lamE [String -> Pat ()
p String
"x"] (Exp () -> QOp () -> Exp () -> Exp ()
inapp (String -> Exp ()
strE String
"_") (String -> QOp ()
op String
"++") (String -> Exp ()
v String
"tpinfoSuffix" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x")))
                Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l
            )
        ]
    genqtypstmt :: (String, String) -> Stmt ()
genqtypstmt (String
tvar, String
qtvar) = Pat () -> Exp () -> Stmt ()
generator (String -> Pat ()
p String
tvar) (String -> Exp ()
v String
qtvar)
    gen :: String -> String -> TemplateFunction -> a -> Stmt ()
gen String
prefix String
nm TemplateFunction
f a
n =
      Pat () -> Exp () -> Stmt ()
generator
        (String -> Pat ()
p (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n))
        ( String -> Exp ()
v String
nm Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE (TemplateClass -> TemplateFunction -> String
hsTmplFuncName TemplateClass
t TemplateFunction
f)
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v (TemplateClass -> TemplateFunction -> String
hsTmplFuncNameTH TemplateClass
t TemplateFunction
f)
            Exp () -> Exp () -> Exp ()
`app` Exp ()
typs_v
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"suffix"
        )
    genstmt :: (a, TemplateFunction) -> Stmt ()
genstmt (a
n, f :: TemplateFunction
f@TFun {}) = String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"f" String
"mkMember" TemplateFunction
f a
n
    genstmt (a
n, f :: TemplateFunction
f@TFunNew {}) = String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"f" String
"mkNew" TemplateFunction
f a
n
    genstmt (a
n, f :: TemplateFunction
f@TemplateFunction
TFunDelete) = String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"f" String
"mkDelete" TemplateFunction
f a
n
    genstmt (a
n, f :: TemplateFunction
f@TFunOp {}) = String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"f" String
"mkMember" TemplateFunction
f a
n
    genvarstmt :: (a, Variable) -> [Stmt ()]
genvarstmt (a
n, Variable
vf) =
      let Variable (Arg {String
Types
arg_type :: Types
arg_name :: String
arg_type :: Arg -> Types
arg_name :: Arg -> String
..}) = Variable
vf
          f_g :: TemplateFunction
f_g =
            TFun
              { tfun_ret :: Types
tfun_ret = Types
arg_type,
                tfun_name :: String
tfun_name = Variable -> Accessor -> String
tmplAccessorName Variable
vf Accessor
Getter,
                tfun_oname :: String
tfun_oname = Variable -> Accessor -> String
tmplAccessorName Variable
vf Accessor
Getter,
                tfun_args :: [Arg]
tfun_args = []
              }
          f_s :: TemplateFunction
f_s =
            TFun
              { tfun_ret :: Types
tfun_ret = Types
Void,
                tfun_name :: String
tfun_name = Variable -> Accessor -> String
tmplAccessorName Variable
vf Accessor
Setter,
                tfun_oname :: String
tfun_oname = Variable -> Accessor -> String
tmplAccessorName Variable
vf Accessor
Setter,
                tfun_args :: [Arg]
tfun_args = [Types -> String -> Arg
Arg Types
arg_type String
"value"]
              }
       in [ String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"vf" String
"mkMember" TemplateFunction
f_g (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1),
            String -> String -> TemplateFunction -> a -> Stmt ()
forall {a}.
Show a =>
String -> String -> TemplateFunction -> a -> Stmt ()
gen String
"vf" String
"mkMember" TemplateFunction
f_s (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n)
          ]
    lststmt :: [Decl ()]
lststmt =
      let mkElems :: String -> [(a, b)] -> [Exp ()]
mkElems String
prefix [(a, b)]
xs = ((a, b) -> Exp ()) -> [(a, b)] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Exp ()
v (String -> Exp ()) -> ((a, b) -> String) -> (a, b) -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\a
n -> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n) (a -> String) -> ((a, b) -> a) -> (a, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
xs
       in [ Pat () -> Exp () -> Decl ()
pbind_
              (String -> Pat ()
p String
"lst")
              ( [Exp ()] -> Exp ()
listE
                  ( String -> [(Int, TemplateFunction)] -> [Exp ()]
forall {a} {b}. Show a => String -> [(a, b)] -> [Exp ()]
mkElems String
"f" [(Int, TemplateFunction)]
nfs
                      [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. Semigroup a => a -> a -> a
<> String -> [(Int, Variable)] -> [Exp ()]
forall {a} {b}. Show a => String -> [(a, b)] -> [Exp ()]
mkElems String
"vf" (((Int, Variable) -> [(Int, Variable)])
-> [(Int, Variable)] -> [(Int, Variable)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
n, Variable
vf) -> [(Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Variable
vf), (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n, Variable
vf)]) [(Int, Variable)]
nvfs)
                  )
              )
          ]
    -- TODO: refactor out the following code.
    foreignSrcStmt :: Stmt ()
foreignSrcStmt =
      Exp () -> Stmt ()
qualifier (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$
        (String -> Exp ()
v String
"addModFinalizer")
          Exp () -> Exp () -> Exp ()
`app` ( String -> Exp ()
v String
"addForeignSource"
                    Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
con String
"LangCxx"
                    Exp () -> Exp () -> Exp ()
`app` ( (Exp () -> Exp () -> Exp ()) -> [Exp ()] -> Exp ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
L.foldr1
                              (\Exp ()
x Exp ()
y -> Exp () -> QOp () -> Exp () -> Exp ()
inapp Exp ()
x (String -> QOp ()
op String
"++") Exp ()
y)
                              [ Exp ()
includeStatic,
                                Exp ()
includeDynamic,
                                Exp ()
namespaceStr,
                                String -> Exp ()
strE (String
tname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_instance"),
                                Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
                                  Exp () -> [Alt ()] -> Exp ()
caseE
                                    (String -> Exp ()
v String
"isCprim")
                                    [ Pat () -> Exp () -> Alt ()
match (String -> Pat ()
p String
"CPrim") (String -> Exp ()
strE String
"_s"),
                                      Pat () -> Exp () -> Alt ()
match (String -> Pat ()
p String
"NonCPrim") (String -> Exp ()
strE String
"")
                                    ],
                                String -> Exp ()
strE String
"(",
                                String -> Exp ()
v String
"intercalate"
                                  Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE String
", "
                                  Exp () -> Exp () -> Exp ()
`app` Exp () -> Exp ()
paren (Exp () -> QOp () -> Exp () -> Exp ()
inapp (String -> Exp ()
v String
"callmod") (String -> QOp ()
op String
":") (String -> Exp ()
v String
"params")),
                                String -> Exp ()
strE String
")\n"
                              ]
                          )
                )
      where
        -- temporary
        body :: [String]
body =
          (CMacro Identity -> String) -> [CMacro Identity] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CMacro Identity -> String
R.renderCMacro ([CMacro Identity] -> [String]) -> [CMacro Identity] -> [String]
forall a b. (a -> b) -> a -> b
$
            (HeaderName -> CMacro Identity)
-> [HeaderName] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (TemplateClassImportHeader -> [HeaderName]
tcihCxxHeaders TemplateClassImportHeader
tcih)
              [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ (TemplateFunction -> CMacro Identity)
-> [TemplateFunction] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map (IsCPrimitive
-> TemplateClass -> TemplateFunction -> CMacro Identity
genTmplFunCpp IsCPrimitive
NonCPrim TemplateClass
t) [TemplateFunction]
fs
              [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ (TemplateFunction -> CMacro Identity)
-> [TemplateFunction] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map (IsCPrimitive
-> TemplateClass -> TemplateFunction -> CMacro Identity
genTmplFunCpp IsCPrimitive
CPrim TemplateClass
t) [TemplateFunction]
fs
              [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ (Variable -> [CMacro Identity]) -> [Variable] -> [CMacro Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (IsCPrimitive -> TemplateClass -> Variable -> [CMacro Identity]
genTmplVarCpp IsCPrimitive
NonCPrim TemplateClass
t) [Variable]
vfs
              [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ (Variable -> [CMacro Identity]) -> [Variable] -> [CMacro Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (IsCPrimitive -> TemplateClass -> Variable -> [CMacro Identity]
genTmplVarCpp IsCPrimitive
CPrim TemplateClass
t) [Variable]
vfs
              [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ [ IsCPrimitive
-> TemplateClass
-> ([TemplateFunction], [Variable])
-> CMacro Identity
genTmplClassCpp IsCPrimitive
NonCPrim TemplateClass
t ([TemplateFunction]
fs, [Variable]
vfs),
                   IsCPrimitive
-> TemplateClass
-> ([TemplateFunction], [Variable])
-> CMacro Identity
genTmplClassCpp IsCPrimitive
CPrim TemplateClass
t ([TemplateFunction]
fs, [Variable]
vfs)
                 ]
        includeStatic :: Exp ()
includeStatic =
          String -> Exp ()
strE (String -> Exp ()) -> String -> Exp ()
forall a b. (a -> b) -> a -> b
$
            (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
              (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")
              ( [CMacro Identity -> String
R.renderCMacro (HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName String
"MacroPatternMatch.h"))]
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
body
              )
        cxxHeaders :: Exp ()
cxxHeaders = String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"tpinfoCxxHeaders") Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l
        cxxNamespaces :: Exp ()
cxxNamespaces = String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"tpinfoCxxNamespaces") Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l
        includeDynamic :: Exp ()
includeDynamic =
          [Decl ()] -> Exp () -> Exp ()
letE
            [ Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"headers") Exp ()
cxxHeaders,
              Pat () -> Exp () -> Decl ()
pbind_
                (Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
"f") [String -> Pat ()
p String
"x"])
                (String -> Exp ()
v String
"renderCMacro" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
con String
"Include" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x"))
            ]
            (String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"f" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"headers")
        namespaceStr :: Exp ()
namespaceStr =
          [Decl ()] -> Exp () -> Exp ()
letE
            [ Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"nss") Exp ()
cxxNamespaces,
              Pat () -> Exp () -> Decl ()
pbind_
                (Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
"f") [String -> Pat ()
p String
"x"])
                (String -> Exp ()
v String
"renderCStmt" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
con String
"UsingNamespace" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x"))
            ]
            (String -> Exp ()
v String
"concatMap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"f" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"nss")
    retstmt :: Exp ()
retstmt =
      String -> Exp ()
v String
"pure"
        Exp () -> Exp () -> Exp ()
`app` [Exp ()] -> Exp ()
listE
          [ String -> Exp ()
v String
"mkInstance"
              Exp () -> Exp () -> Exp ()
`app` [Exp ()] -> Exp ()
listE []
              Exp () -> Exp () -> Exp ()
`app` (Exp () -> Exp () -> Exp ()) -> [Exp ()] -> Exp ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
                (\Exp ()
f Exp ()
x -> String -> Exp ()
con String
"AppT" Exp () -> Exp () -> Exp ()
`app` Exp ()
f Exp () -> Exp () -> Exp ()
`app` Exp ()
x)
                (String -> Exp ()
v String
"con" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE (TemplateClass -> String
typeclassNameT TemplateClass
t) Exp () -> [Exp ()] -> [Exp ()]
forall a. a -> [a] -> [a]
: (String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)
              Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"lst")
          ]

---------------
-- top-level --
---------------

-- |
genTLTemplateInterface :: TLTemplate -> [Decl ()]
genTLTemplateInterface :: TLTemplate -> [Decl ()]
genTLTemplateInterface TLTemplate
t =
  [ Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()
mkClass Context ()
cxEmpty (String -> String
firstUpper (TLTemplate -> String
topleveltfunc_name TLTemplate
t)) ((String -> TyVarBind ()) -> [String] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> TyVarBind ()
mkTBind [String]
tps) [ClassDecl ()]
methods
  ]
  where
    tps :: [String]
tps = TLTemplate -> [String]
topleveltfunc_params TLTemplate
t
    ctyp :: Type ()
ctyp = Maybe Class -> Types -> Type ()
convertCpp2HS Maybe Class
forall a. Maybe a
Nothing (TLTemplate -> Types
topleveltfunc_ret TLTemplate
t)
    lst :: [Type ()]
lst = (Arg -> Type ()) -> [Arg] -> [Type ()]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Class -> Types -> Type ()
convertCpp2HS Maybe Class
forall a. Maybe a
Nothing (Types -> Type ()) -> (Arg -> Types) -> Arg -> Type ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Types
arg_type) (TLTemplate -> [Arg]
topleveltfunc_args TLTemplate
t)
    sigdecl :: Decl ()
sigdecl = String -> Type () -> Decl ()
mkFunSig (TLTemplate -> String
topleveltfunc_name TLTemplate
t) (Type () -> Decl ()) -> Type () -> Decl ()
forall a b. (a -> b) -> a -> b
$ (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun ([Type ()]
lst [Type ()] -> [Type ()] -> [Type ()]
forall a. Semigroup a => a -> a -> a
<> [Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"IO") Type ()
ctyp])
    methods :: [ClassDecl ()]
methods = [Decl () -> ClassDecl ()
clsDecl Decl ()
sigdecl]

-- |
genTLTemplateImplementation :: TLTemplate -> [Decl ()]
genTLTemplateImplementation :: TLTemplate -> [Decl ()]
genTLTemplateImplementation TLTemplate
t =
  String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun String
nh Type ()
sig ([Pat ()]
tvars_p [Pat ()] -> [Pat ()] -> [Pat ()]
forall a. [a] -> [a] -> [a]
++ [String -> Pat ()
p String
"suffix"]) Exp ()
rhs (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just Binds ()
bstmts)
  where
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    itps :: [(Int, String)]
itps = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) (TLTemplate -> [String]
topleveltfunc_params TLTemplate
t)
    tvars :: [String]
tvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    nparams :: Int
nparams = [(Int, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
itps
    tparams :: Type ()
tparams = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String -> Type ()
tycon String
"Type" else () -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed (Int -> Type () -> [Type ()]
forall a. Int -> a -> [a]
replicate Int
nparams (String -> Type ()
tycon String
"Type"))
    sig :: Type ()
sig = (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun [Type ()
tparams, String -> Type ()
tycon String
"String", Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"Q") (String -> Type ()
tycon String
"Exp")]
    tvars_p :: [Pat ()]
tvars_p = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars else [[Pat ()] -> Pat ()
pTuple ((String -> Pat ()) -> [String] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Pat ()
p [String]
tvars)]
    prefix :: String
prefix = String
"TL"
    nh :: String
nh = String
"t_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TLTemplate -> String
topleveltfunc_name TLTemplate
t
    nc :: String
nc = TLTemplate -> String
topleveltfunc_name TLTemplate
t
    lit' :: Exp ()
lit' = String -> Exp ()
strE (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
nc)
    lam :: Exp ()
lam = [Pat ()] -> Exp () -> Exp ()
lamE [String -> Pat ()
p String
"n"] (Exp ()
lit' Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"<>" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"n")
    rhs :: Exp ()
rhs =
      Exp () -> Exp () -> Exp ()
app (String -> Exp ()
v String
"mkTFunc") (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
        let typs :: [Exp ()]
typs = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars else [[Exp ()] -> Exp ()
tuple ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)]
         in [Exp ()] -> Exp ()
tuple ([Exp ()]
typs [Exp ()] -> [Exp ()] -> [Exp ()]
forall a. [a] -> [a] -> [a]
++ [String -> Exp ()
v String
"suffix", Exp ()
lam, String -> Exp ()
v String
"tyf"])
    sig' :: Type ()
sig' =
      let e :: a
e = String -> a
forall a. HasCallStack => String -> a
error String
"genTLTemplateImplementation"
          spls :: [Type ()]
spls = (String -> Type ()) -> [String] -> [Type ()]
forall a b. (a -> b) -> [a] -> [b]
map (Splice () -> Type ()
tySplice (Splice () -> Type ())
-> (String -> Splice ()) -> String -> Type ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp () -> Splice ()
parenSplice (Exp () -> Splice ()) -> (String -> Exp ()) -> String -> Splice ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
mkVar) ([String] -> [Type ()]) -> [String] -> [Type ()]
forall a b. (a -> b) -> a -> b
$ TLTemplate -> [String]
topleveltfunc_params TLTemplate
t
          ctyp :: Type ()
ctyp = Type () -> Maybe Class -> [Type ()] -> Types -> Type ()
convertCpp2HS4Tmpl Type ()
forall {a}. a
e Maybe Class
forall a. Maybe a
Nothing [Type ()]
spls (TLTemplate -> Types
topleveltfunc_ret TLTemplate
t)
          lst :: [Type ()]
lst = (Arg -> Type ()) -> [Arg] -> [Type ()]
forall a b. (a -> b) -> [a] -> [b]
map (Type () -> Maybe Class -> [Type ()] -> Types -> Type ()
convertCpp2HS4Tmpl Type ()
forall {a}. a
e Maybe Class
forall a. Maybe a
Nothing [Type ()]
spls (Types -> Type ()) -> (Arg -> Types) -> Arg -> Type ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Types
arg_type) (TLTemplate -> [Arg]
topleveltfunc_args TLTemplate
t)
       in (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun ([Type ()]
lst [Type ()] -> [Type ()] -> [Type ()]
forall a. Semigroup a => a -> a -> a
<> [Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"IO") Type ()
ctyp])
    tassgns :: [Decl ()]
tassgns = ((Int, String) -> Decl ()) -> [(Int, String)] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
tp) -> Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
tp) (String -> Exp ()
v String
"pure" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v (String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)))) [(Int, String)]
itps
    bstmts :: Binds ()
bstmts =
      [Decl ()] -> Binds ()
binds
        [ String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1
            String
"tyf"
            [Pat ()
wildcard]
            ( [Decl ()] -> Exp () -> Exp ()
letE
                [Decl ()]
tassgns
                (Bracket () -> Exp ()
bracketExp (Type () -> Bracket ()
typeBracket Type ()
sig'))
            )
            Maybe (Binds ())
forall a. Maybe a
Nothing
        ]

genTLTemplateInstance ::
  TopLevelImportHeader ->
  TLTemplate ->
  [Decl ()]
genTLTemplateInstance :: TopLevelImportHeader -> TLTemplate -> [Decl ()]
genTLTemplateInstance TopLevelImportHeader
tih TLTemplate
t =
  String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun
    String
fname
    Type ()
sig
    (String -> Pat ()
p String
"isCprim" Pat () -> [Pat ()] -> [Pat ()]
forall a. a -> [a] -> [a]
: (String -> String -> Pat ()) -> [String] -> [String] -> [Pat ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
x String
y -> [Pat ()] -> Pat ()
pTuple [String -> Pat ()
p String
x, String -> Pat ()
p String
y]) [String]
qtvars [String]
pvars)
    Exp ()
rhs
    Maybe (Binds ())
forall a. Maybe a
Nothing
  where
    p :: String -> Pat ()
p = String -> Pat ()
mkPVar
    v :: String -> Exp ()
v = String -> Exp ()
mkVar
    tcname :: String
tcname = String -> String
firstUpper (TLTemplate -> String
topleveltfunc_name TLTemplate
t)
    fname :: String
fname = String
"gen" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tcname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"InstanceFor"
    itps :: [(Int, String)]
itps = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1 ..] :: [Int]) (TLTemplate -> [String]
topleveltfunc_params TLTemplate
t)
    tvars :: [String]
tvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"typ" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    qtvars :: [String]
qtvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"qtyp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    pvars :: [String]
pvars = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
_) -> String
"param" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int, String)]
itps
    nparams :: Int
nparams = [(Int, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, String)]
itps
    typs_v :: Exp ()
typs_v = if Int
nparams Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String -> Exp ()
v ([String]
tvars [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) else [Exp ()] -> Exp ()
tuple ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)
    params_l :: Exp ()
params_l = [Exp ()] -> Exp ()
listE ((String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
pvars)
    sig :: Type ()
sig =
      (Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun ([Type ()] -> Type ()) -> [Type ()] -> Type ()
forall a b. (a -> b) -> a -> b
$
        [String -> Type ()
tycon String
"IsCPrimitive"]
          [Type ()] -> [Type ()] -> [Type ()]
forall a. [a] -> [a] -> [a]
++ Int -> Type () -> [Type ()]
forall a. Int -> a -> [a]
replicate
            Int
nparams
            (() -> Boxed -> [Type ()] -> Type ()
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
Boxed [String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` String -> Type ()
tycon String
"Type", String -> Type ()
tycon String
"TemplateParamInfo"])
          [Type ()] -> [Type ()] -> [Type ()]
forall a. [a] -> [a] -> [a]
++ [String -> Type ()
tycon String
"Q" Type () -> Type () -> Type ()
`tyapp` Type () -> Type ()
tylist (String -> Type ()
tycon String
"Dec")]
    -- nvfs = zip ([1..] :: [Int]) vfs

    --------------------------
    -- final RHS expression --
    --------------------------
    rhs :: Exp ()
rhs =
      [Stmt ()] -> Exp ()
doE
        ( [Stmt ()
paramsstmt, Stmt ()
suffixstmt]
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> [ Pat () -> Exp () -> Stmt ()
generator (String -> Pat ()
p String
"callmod_") (String -> Exp ()
v String
"fmap" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"loc_module" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"location")),
                 [Decl ()] -> Stmt ()
letStmt
                   [ Pat () -> Exp () -> Decl ()
pbind_
                       (String -> Pat ()
p String
"callmod")
                       (String -> Exp ()
v String
"dot2_" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"callmod_")
                   ]
               ]
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> ((String, String) -> Stmt ()) -> [(String, String)] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> Stmt ()
genqtypstmt ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
tvars [String]
qtvars)
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> [String -> Int -> Stmt ()
forall {a}. Show a => String -> a -> Stmt ()
genstmt String
"f" (Int
1 :: Int)]
            [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. Semigroup a => a -> a -> a
<> [ Stmt ()
foreignSrcStmt,
                 [Decl ()] -> Stmt ()
letStmt [Decl ()]
lststmt,
                 Exp () -> Stmt ()
qualStmt Exp ()
retstmt
               ]
        )
    --------------------------
    paramsstmt :: Stmt ()
paramsstmt =
      [Decl ()] -> Stmt ()
letStmt
        [ Pat () -> Exp () -> Decl ()
pbind_
            (String -> Pat ()
p String
"params")
            (String -> Exp ()
v String
"map" Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"tpinfoSuffix") Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l)
        ]
    suffixstmt :: Stmt ()
suffixstmt =
      [Decl ()] -> Stmt ()
letStmt
        [ Pat () -> Exp () -> Decl ()
pbind_
            (String -> Pat ()
p String
"suffix")
            ( String -> Exp ()
v String
"concatMap"
                Exp () -> Exp () -> Exp ()
`app` ([Pat ()] -> Exp () -> Exp ()
lamE [String -> Pat ()
p String
"x"] (Exp () -> QOp () -> Exp () -> Exp ()
inapp (String -> Exp ()
strE String
"_") (String -> QOp ()
op String
"++") (String -> Exp ()
v String
"tpinfoSuffix" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"x")))
                Exp () -> Exp () -> Exp ()
`app` Exp ()
params_l
            )
        ]
    genqtypstmt :: (String, String) -> Stmt ()
genqtypstmt (String
tvar, String
qtvar) = Pat () -> Exp () -> Stmt ()
generator (String -> Pat ()
p String
tvar) (String -> Exp ()
v String
qtvar)
    genstmt :: String -> a -> Stmt ()
genstmt String
prefix a
n =
      Pat () -> Exp () -> Stmt ()
generator
        (String -> Pat ()
p (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n))
        ( String -> Exp ()
v String
"mkFunc" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE (TLTemplate -> String
topleveltfunc_name TLTemplate
t)
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v (String
"t_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TLTemplate -> String
topleveltfunc_name TLTemplate
t)
            Exp () -> Exp () -> Exp ()
`app` Exp ()
typs_v
            Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
v String
"suffix"
        )
    lststmt :: [Decl ()]
lststmt = [Pat () -> Exp () -> Decl ()
pbind_ (String -> Pat ()
p String
"lst") ([Exp ()] -> Exp ()
listE [String -> Exp ()
v String
"f1"])]
    -- TODO: refactor out the following code.
    foreignSrcStmt :: Stmt ()
foreignSrcStmt =
      Exp () -> Stmt ()
qualifier (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$
        (String -> Exp ()
v String
"addModFinalizer")
          Exp () -> Exp () -> Exp ()
`app` ( String -> Exp ()
v String
"addForeignSource"
                    Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
con String
"LangCxx"
                    Exp () -> Exp () -> Exp ()
`app` ( (Exp () -> Exp () -> Exp ()) -> [Exp ()] -> Exp ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
L.foldr1
                              (\Exp ()
x Exp ()
y -> Exp () -> QOp () -> Exp () -> Exp ()
inapp Exp ()
x (String -> QOp ()
op String
"++") Exp ()
y)
                              [ Exp ()
includeStatic,
                                {-                        , includeDynamic
                                                        , namespaceStr -}
                                String -> Exp ()
strE (String
tcname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_instance"),
                                Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
                                  Exp () -> [Alt ()] -> Exp ()
caseE
                                    (String -> Exp ()
v String
"isCprim")
                                    [ Pat () -> Exp () -> Alt ()
match (String -> Pat ()
p String
"CPrim") (String -> Exp ()
strE String
"_s"),
                                      Pat () -> Exp () -> Alt ()
match (String -> Pat ()
p String
"NonCPrim") (String -> Exp ()
strE String
"")
                                    ],
                                String -> Exp ()
strE String
"(",
                                String -> Exp ()
v String
"intercalate"
                                  Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE String
", "
                                  Exp () -> Exp () -> Exp ()
`app` Exp () -> Exp ()
paren (Exp () -> QOp () -> Exp () -> Exp ()
inapp (String -> Exp ()
v String
"callmod") (String -> QOp ()
op String
":") (String -> Exp ()
v String
"params")),
                                String -> Exp ()
strE String
")\n"
                              ]
                          )
                )
      where
        -- temporary
        includeStatic :: Exp ()
includeStatic =
          String -> Exp ()
strE (String -> Exp ()) -> String -> Exp ()
forall a b. (a -> b) -> a -> b
$
            (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
              (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")
              ( [CMacro Identity -> String
R.renderCMacro (HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName String
"MacroPatternMatch.h"))]
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (CMacro Identity -> String) -> [CMacro Identity] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
                    CMacro Identity -> String
R.renderCMacro
                    ( (HeaderName -> CMacro Identity)
-> [HeaderName] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (TopLevelImportHeader -> [HeaderName]
tihExtraHeadersInCPP TopLevelImportHeader
tih)
                        [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. [a] -> [a] -> [a]
++ [IsCPrimitive -> TLTemplate -> CMacro Identity
genTLTmplFunCpp IsCPrimitive
CPrim TLTemplate
t, IsCPrimitive -> TLTemplate -> CMacro Identity
genTLTmplFunCpp IsCPrimitive
NonCPrim TLTemplate
t]
                    )
              )
    {-
    cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l
    cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l

    includeDynamic =
      letE
        [ pbind_ (p "headers") cxxHeaders,
          pbind_
            (pApp (name "f") [p "x"])
            (v "renderCMacro" `app` (con "Include" `app` v "x"))
        ]
        (v "concatMap" `app` v "f" `app` v "headers")

    namespaceStr =
      letE
        [ pbind_ (p "nss") cxxNamespaces,
          pbind_
            (pApp (name "f") [p "x"])
            (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x"))
        ]
        (v "concatMap" `app` v "f" `app` v "nss")
    -}
    retstmt :: Exp ()
retstmt =
      String -> Exp ()
v String
"pure"
        Exp () -> Exp () -> Exp ()
`app` [Exp ()] -> Exp ()
listE
          [ String -> Exp ()
v String
"mkInstance"
              Exp () -> Exp () -> Exp ()
`app` [Exp ()] -> Exp ()
listE []
              -- `app` (v "con" `app` strE tcname)
              Exp () -> Exp () -> Exp ()
`app` (Exp () -> Exp () -> Exp ()) -> [Exp ()] -> Exp ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
                (\Exp ()
f Exp ()
x -> String -> Exp ()
con String
"AppT" Exp () -> Exp () -> Exp ()
`app` Exp ()
f Exp () -> Exp () -> Exp ()
`app` Exp ()
x)
                (String -> Exp ()
v String
"con" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
strE String
tcname Exp () -> [Exp ()] -> [Exp ()]
forall a. a -> [a] -> [a]
: (String -> Exp ()) -> [String] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Exp ()
v [String]
tvars)
              Exp () -> Exp () -> Exp ()
`app` (String -> Exp ()
v String
"lst")
          ]