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

module FFICXX.Generate.Code.HsTemplate where

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


------------------------------
-- 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 (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 (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 (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 =
  let
    deps_raw :: [Either TemplateClass Class]
deps_raw  = Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepRaw (TemplateClass -> Either TemplateClass Class
forall a b. a -> Either a b
Left TemplateClass
t0)
    deps_high :: [Either TemplateClass Class]
deps_high = Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepHighSource (TemplateClass -> Either TemplateClass Class
forall a b. a -> Either a b
Left TemplateClass
t0)
  in     ((Either TemplateClass Class -> ImportDecl ())
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> ImportDecl ())
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> ImportDecl ())
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map [Either TemplateClass Class]
deps_raw
           (\case
             Left TemplateClass
t -> String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")
             Right Class
c -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.> String
"RawType")
           )
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ((Either TemplateClass Class -> ImportDecl ())
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> ImportDecl ())
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> ImportDecl ())
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map [Either TemplateClass Class]
deps_high
           (\case
             Left TemplateClass
t -> String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")
             Right Class
c -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.> String
"Interface")
           )

-- |
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 (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 (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 =
  let
    deps_raw :: [Either TemplateClass Class]
deps_raw  = Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepRaw (TemplateClass -> Either TemplateClass Class
forall a b. a -> Either a b
Left TemplateClass
t0)
    deps_high :: [Either TemplateClass Class]
deps_high = Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepHighSource (TemplateClass -> Either TemplateClass Class
forall a b. a -> Either a b
Left TemplateClass
t0)
  in     ((Either TemplateClass Class -> [ImportDecl ()])
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> [ImportDecl ()])
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> [ImportDecl ()])
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Either TemplateClass Class]
deps_raw
           (\case
             Left TemplateClass
t  -> [String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")]
             Right Class
c -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.> String
y)) [String
"RawType",String
"Cast",String
"Interface"]
           )
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ((Either TemplateClass Class -> [ImportDecl ()])
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> [ImportDecl ()])
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> [ImportDecl ()])
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Either TemplateClass Class]
deps_high
           (\case
             Left TemplateClass
t  -> [String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")]
             Right Class
c -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.> String
y)) [String
"RawType",String
"Cast",String
"Interface"]
           )

-- |
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 (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 (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
prefixString -> 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] -- [mkPVar "n"]
                               ([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 (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. [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 (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
prefixString -> 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
[Arg]
Types
tfun_args :: TemplateFunction -> [Arg]
tfun_oname :: TemplateFunction -> String
tfun_name :: TemplateFunction -> String
tfun_ret :: TemplateFunction -> Types
tfun_args :: [Arg]
tfun_oname :: String
tfun_name :: String
tfun_ret :: Types
..}) = 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 {[Arg]
Maybe String
tfun_new_alias :: TemplateFunction -> Maybe String
tfun_new_args :: TemplateFunction -> [Arg]
tfun_new_alias :: Maybe String
tfun_new_args :: [Arg]
..}) = 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
OpExp
Types
tfun_opexp :: TemplateFunction -> OpExp
tfun_opexp :: OpExp
tfun_name :: String
tfun_ret :: Types
tfun_name :: TemplateFunction -> String
tfun_ret :: TemplateFunction -> Types
..}) = 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_name :: Arg -> String
arg_type :: Arg -> Types
arg_name :: String
arg_type :: Types
..}) = Variable
vf
        f_g :: TemplateFunction
f_g = TFun :: Types -> String -> String -> [Arg] -> TemplateFunction
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 :: Types -> String -> String -> [Arg] -> TemplateFunction
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
2a -> a -> a
forall a. Num a => a -> a -> a
*a
na -> 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
2a -> 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
prefixString -> 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
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Variable
vf),(Int
2Int -> 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 (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 (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")
                          ]