{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

module FFICXX.Generate.ContentMaker where

import Control.Lens (at, (&), (.~))
import Control.Monad.Trans.Reader (runReader)
import Data.Either (rights)
import Data.Functor.Identity (Identity)
import Data.List (intercalate, nub)
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import FFICXX.Generate.Code.Cpp
  ( genAllCppHeaderInclude,
    genCppDefInstAccessor,
    genCppDefInstNonVirtual,
    genCppDefInstVirtual,
    genCppDefMacroAccessor,
    genCppDefMacroNonVirtual,
    genCppDefMacroTemplateMemberFunction,
    genCppDefMacroVirtual,
    genCppHeaderInstAccessor,
    genCppHeaderInstNonVirtual,
    genCppHeaderInstVirtual,
    genCppHeaderMacroAccessor,
    genCppHeaderMacroNonVirtual,
    genCppHeaderMacroType,
    genCppHeaderMacroVirtual,
    genTopLevelCppDefinition,
    topLevelDecl,
  )
import FFICXX.Generate.Code.HsCast
  ( genHsFrontInstCastable,
    genHsFrontInstCastableSelf,
  )
import FFICXX.Generate.Code.HsFFI
  ( genHsFFI,
    genImportInFFI,
    genTopLevelFFI,
  )
import FFICXX.Generate.Code.HsFrontEnd
  ( genExport,
    genExtraImport,
    genHsFrontDecl,
    genHsFrontDowncastClass,
    genHsFrontInst,
    genHsFrontInstNew,
    genHsFrontInstNonVirtual,
    genHsFrontInstStatic,
    genHsFrontInstVariables,
    genHsFrontUpcastClass,
    genImportForTLOrdinary,
    genImportForTLTemplate,
    genImportInCast,
    genImportInImplementation,
    genImportInInterface,
    genImportInModule,
    genImportInTopLevel,
    genTopLevelDef,
    hsClassRawType,
  )
import FFICXX.Generate.Code.HsProxy (genProxyInstance)
import FFICXX.Generate.Code.HsTemplate
  ( genImportInTH,
    genImportInTemplate,
    genTLTemplateImplementation,
    genTLTemplateInstance,
    genTLTemplateInterface,
    genTemplateMemberFunctions,
    genTmplImplementation,
    genTmplInstance,
    genTmplInterface,
  )
import FFICXX.Generate.Dependency
  ( class_allparents,
    mkDaughterMap,
    mkDaughterSelfMap,
  )
import FFICXX.Generate.Name
  ( ffiClassName,
    hsClassName,
    hsFrontNameForTopLevel,
  )
import FFICXX.Generate.Type.Annotate (AnnotateMap)
import FFICXX.Generate.Type.Class
  ( Class (..),
    ClassGlobal (..),
    DaughterMap,
    ProtectedMethod (..),
    TopLevel (TLOrdinary, TLTemplate),
    filterTLOrdinary,
    filterTLTemplate,
    isAbstractClass,
  )
import FFICXX.Generate.Type.Module
  ( ClassImportHeader (..),
    ClassModule (..),
    DepCycles,
    TemplateClassImportHeader (..),
    TemplateClassModule (..),
    TopLevelImportHeader (..),
  )
import FFICXX.Generate.Type.PackageInterface
  ( ClassName (..),
    PackageInterface,
    PackageName (..),
  )
import FFICXX.Generate.Util (firstUpper)
import FFICXX.Generate.Util.HaskellSrcExts
  ( emodule,
    evar,
    lang,
    mkImport,
    mkModule,
    mkModuleE,
    unqual,
  )
import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
import qualified FFICXX.Runtime.CodeGen.Cxx as R
import Language.Haskell.Exts.Syntax
  ( Decl (..),
    EWildcard (EWildcard),
    ExportSpec (EThingWith),
    Module (..),
  )
import System.FilePath ((<.>), (</>))

srcDir :: FilePath -> FilePath
srcDir :: String -> String
srcDir String
installbasedir = String
installbasedir String -> String -> String
</> String
"src"

csrcDir :: FilePath -> FilePath
csrcDir :: String -> String
csrcDir String
installbasedir = String
installbasedir String -> String -> String
</> String
"csrc"

---- common function for daughter

-- |
mkGlobal :: [Class] -> ClassGlobal
mkGlobal :: [Class] -> ClassGlobal
mkGlobal = DaughterMap -> DaughterMap -> ClassGlobal
ClassGlobal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Class] -> DaughterMap
mkDaughterSelfMap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Class] -> DaughterMap
mkDaughterMap

-- |
buildDaughterDef ::
  ((String, [Class]) -> String) ->
  DaughterMap ->
  String
buildDaughterDef :: ((String, [Class]) -> String) -> DaughterMap -> String
buildDaughterDef (String, [Class]) -> String
f DaughterMap
m =
  let lst :: [(String, [Class])]
lst = forall k a. Map k a -> [(k, a)]
M.toList DaughterMap
m
      f' :: (String, [Class]) -> String
f' (String
x, [Class]
xs) = (String, [Class]) -> String
f (String
x, forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Bool
isAbstractClass) [Class]
xs)
   in (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [Class]) -> String
f' [(String, [Class])]
lst)

-- |
buildParentDef :: ((Class, Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity]
buildParentDef :: ((Class, Class) -> [CStatement Identity])
-> Class -> [CStatement Identity]
buildParentDef (Class, Class) -> [CStatement Identity]
f Class
cls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
p -> (Class, Class) -> [CStatement Identity]
f (Class
p, Class
cls)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Class]
class_allparents forall a b. (a -> b) -> a -> b
$ Class
cls

-- |
mkProtectedFunctionList :: Class -> [R.CMacro Identity]
mkProtectedFunctionList :: Class -> [CMacro Identity]
mkProtectedFunctionList Class
c =
  forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> forall (f :: * -> *).
CName f -> [CName f] -> [CStatement f] -> CMacro f
R.Define (String -> CName Identity
R.sname (String
"IS_" forall a. Semigroup a => a -> a -> a
<> Class -> String
class_name Class
c forall a. Semigroup a => a -> a -> a
<> String
"_" forall a. Semigroup a => a -> a -> a
<> String
x forall a. Semigroup a => a -> a -> a
<> String
"_PROTECTED")) [] [forall (f :: * -> *). String -> CStatement f
R.CVerbatim String
"()"])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtectedMethod -> [String]
unProtected
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> ProtectedMethod
class_protected
    forall a b. (a -> b) -> a -> b
$ Class
c

-- |
buildTypeDeclHeader ::
  [Class] ->
  String
buildTypeDeclHeader :: [Class] -> String
buildTypeDeclHeader [Class]
classes =
  let typeDeclBodyStmts :: [CMacro Identity]
typeDeclBodyStmts =
        forall a. [a] -> [[a]] -> [a]
intercalate [forall (f :: * -> *). CMacro f
R.EmptyLine] forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [CStatement Identity]
genCppHeaderMacroType) [Class]
classes
   in CBlock Identity -> String
R.renderBlock forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC forall a b. (a -> b) -> a -> b
$
          [forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, forall (f :: * -> *). CMacro f
R.EmptyLine] forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
typeDeclBodyStmts

-- |
buildDeclHeader ::
  -- | C prefix
  String ->
  ClassImportHeader ->
  String
buildDeclHeader :: String -> ClassImportHeader -> String
buildDeclHeader String
cprefix ClassImportHeader
header =
  let classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass ClassImportHeader
header]
      aclass :: Class
aclass = ClassImportHeader -> Class
cihClass ClassImportHeader
header
      declHeaderStmts :: [CMacro Identity]
declHeaderStmts =
        [forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (String
cprefix forall a. [a] -> [a] -> [a]
++ String
"Type.h"))]
          forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). HeaderName -> CMacro f
R.Include (ClassImportHeader -> [HeaderName]
cihIncludedHPkgHeadersInH ClassImportHeader
header)
      vdecl :: [CMacro Identity]
vdecl = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroVirtual [Class]
classes
      nvdecl :: [CMacro Identity]
nvdecl = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroNonVirtual [Class]
classes
      acdecl :: [CMacro Identity]
acdecl = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroAccessor [Class]
classes
      vdef :: [CMacro Identity]
vdef = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroVirtual [Class]
classes
      nvdef :: [CMacro Identity]
nvdef = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroNonVirtual [Class]
classes
      acdef :: [CMacro Identity]
acdef = forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroAccessor [Class]
classes
      tmpldef :: [[CMacro Identity]]
tmpldef = forall a b. (a -> b) -> [a] -> [b]
map (\Class
c -> forall a b. (a -> b) -> [a] -> [b]
map (Class -> TemplateMemberFunction -> CMacro Identity
genCppDefMacroTemplateMemberFunction Class
c) (Class -> [TemplateMemberFunction]
class_tmpl_funcs Class
c)) [Class]
classes
      declDefStmts :: [CMacro Identity]
declDefStmts =
        forall a. [a] -> [[a]] -> [a]
intercalate [forall (f :: * -> *). CMacro f
R.EmptyLine] forall a b. (a -> b) -> a -> b
$ [[CMacro Identity]
vdecl, [CMacro Identity]
nvdecl, [CMacro Identity]
acdecl, [CMacro Identity]
vdef, [CMacro Identity]
nvdef, [CMacro Identity]
acdef] forall a. [a] -> [a] -> [a]
++ [[CMacro Identity]]
tmpldef
      classDeclStmts :: [CStatement Identity]
classDeclStmts =
        -- NOTE: Deletable is treated specially.
        -- TODO: We had better make it as a separate constructor in Class.
        if (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> (String, String)
hsClassName) Class
aclass forall a. Eq a => a -> a -> Bool
/= String
"Deletable"
          then
            ((Class, Class) -> [CStatement Identity])
-> Class -> [CStatement Identity]
buildParentDef (\(Class
p, Class
c) -> [(Class, Class) -> CStatement Identity
genCppHeaderInstVirtual (Class
p, Class
c), forall (f :: * -> *). CStatement f
R.CEmptyLine]) Class
aclass
              forall a. Semigroup a => a -> a -> a
<> [(Class, Class) -> CStatement Identity
genCppHeaderInstVirtual (Class
aclass, Class
aclass), forall (f :: * -> *). CStatement f
R.CEmptyLine]
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppHeaderInstNonVirtual Class
c, forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppHeaderInstAccessor Class
c, forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
          else []
   in CBlock Identity -> String
R.renderBlock forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC forall a b. (a -> b) -> a -> b
$
          [forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declHeaderStmts
            forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declDefStmts
            forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
classDeclStmts

-- |
buildDefMain ::
  ClassImportHeader ->
  String
buildDefMain :: ClassImportHeader -> String
buildDefMain ClassImportHeader
cih =
  let classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass ClassImportHeader
cih]
      headerStmts :: [CMacro Identity]
headerStmts =
        [forall (f :: * -> *). HeaderName -> CMacro f
R.Include HeaderName
"MacroPatternMatch.h"]
          forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> [CMacro Identity]
genAllCppHeaderInclude ClassImportHeader
cih
          forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). HeaderName -> CMacro f
R.Include (ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
cih)]
      namespaceStmts :: [CStatement Identity]
namespaceStmts =
        (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). Namespace -> CStatement f
R.UsingNamespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassImportHeader -> [Namespace]
cihNamespace) ClassImportHeader
cih
      aclass :: Class
aclass = ClassImportHeader -> Class
cihClass ClassImportHeader
cih
      aliasStr :: String
aliasStr =
        forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe String
typedefstmt forall a b. (a -> b) -> a -> b
$
            Class
aclass forall a. a -> [a] -> [a]
: forall a b. [Either a b] -> [b]
rights (ClassImportHeader -> [Either TemplateClass Class]
cihImportedClasses ClassImportHeader
cih)
        where
          typedefstmt :: Class -> Maybe String
typedefstmt Class
c =
            let n1 :: String
n1 = Class -> String
class_name Class
c
                n2 :: String
n2 = Class -> String
ffiClassName Class
c
             in if String
n1 forall a. Eq a => a -> a -> Bool
== String
n2
                  then forall a. Maybe a
Nothing
                  else forall a. a -> Maybe a
Just (String
"typedef " forall a. Semigroup a => a -> a -> a
<> String
n1 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
n2 forall a. Semigroup a => a -> a -> a
<> String
";")
      cppBodyStmts :: [CMacro Identity]
cppBodyStmts =
        Class -> [CMacro Identity]
mkProtectedFunctionList (ClassImportHeader -> Class
cihClass ClassImportHeader
cih)
          forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map
            forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular
            ( ((Class, Class) -> [CStatement Identity])
-> Class -> [CStatement Identity]
buildParentDef (\(Class
p, Class
c) -> [(Class, Class) -> CStatement Identity
genCppDefInstVirtual (Class
p, Class
c), forall (f :: * -> *). CStatement f
R.CEmptyLine]) (ClassImportHeader -> Class
cihClass ClassImportHeader
cih)
                forall a. Semigroup a => a -> a -> a
<> ( if Class -> Bool
isAbstractClass Class
aclass
                       then []
                       else [(Class, Class) -> CStatement Identity
genCppDefInstVirtual (Class
aclass, Class
aclass), forall (f :: * -> *). CStatement f
R.CEmptyLine]
                   )
                forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppDefInstNonVirtual Class
c, forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
                forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppDefInstAccessor Class
c, forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
            )
   in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        CMacro Identity -> String
R.renderCMacro
        ( [CMacro Identity]
headerStmts
            forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
namespaceStmts
            forall a. Semigroup a => a -> a -> a
<> [ forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim String
aliasStr,
                 forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim String
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",
                 forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim
                   String
"#define TYPECASTMETHOD(cname,mname,oname) \\\n\
                   \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\
                   \  (from_nonconst_to_nonconst<oname,cname ## _t>), \\\n\
                   \  (from_nonconst_to_nonconst<cname,cname ## _t>) )\n",
                 forall (f :: * -> *). CMacro f
R.EmptyLine
               ]
            forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
cppBodyStmts
        )

-- |
buildTopLevelHeader ::
  -- | C prefix
  String ->
  TopLevelImportHeader ->
  String
buildTopLevelHeader :: String -> TopLevelImportHeader -> String
buildTopLevelHeader String
cprefix TopLevelImportHeader
tih =
  let declHeaderStmts :: [CMacro Identity]
declHeaderStmts =
        [forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (String
cprefix forall a. [a] -> [a] -> [a]
++ String
"Type.h"))]
          forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). HeaderName -> CMacro f
R.Include (forall a b. (a -> b) -> [a] -> [b]
map ClassImportHeader -> HeaderName
cihSelfHeader (TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih) forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [HeaderName]
tihExtraHeadersInH TopLevelImportHeader
tih)
      declBodyStmts :: [CStatement Identity]
declBodyStmts = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *). CFunDecl f -> CStatement f
R.CDeclaration forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> CFunDecl Identity
topLevelDecl) forall a b. (a -> b) -> a -> b
$ [TopLevel] -> [TLOrdinary]
filterTLOrdinary (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
   in CBlock Identity -> String
R.renderBlock forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC forall a b. (a -> b) -> a -> b
$
          [forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declHeaderStmts
            forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
declBodyStmts

-- |
buildTopLevelCppDef :: TopLevelImportHeader -> String
buildTopLevelCppDef :: TopLevelImportHeader -> String
buildTopLevelCppDef TopLevelImportHeader
tih =
  let cihs :: [ClassImportHeader]
cihs = TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih
      extclasses :: [Either TemplateClass Class]
extclasses = TopLevelImportHeader -> [Either TemplateClass Class]
tihExtraClassDep TopLevelImportHeader
tih
      declHeaderStmts :: [CMacro Identity]
declHeaderStmts =
        [ forall (f :: * -> *). HeaderName -> CMacro f
R.Include HeaderName
"MacroPatternMatch.h",
          forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (TopLevelImportHeader -> String
tihHeaderFileName TopLevelImportHeader
tih String -> String -> String
<.> String
"h"))
        ]
          forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClassImportHeader -> [CMacro Identity]
genAllCppHeaderInclude [ClassImportHeader]
cihs
          forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
otherHeaderStmts
      otherHeaderStmts :: [CMacro Identity]
otherHeaderStmts =
        forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). HeaderName -> CMacro f
R.Include (forall a b. (a -> b) -> [a] -> [b]
map ClassImportHeader -> HeaderName
cihSelfHeader [ClassImportHeader]
cihs forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [HeaderName]
tihExtraHeadersInCPP TopLevelImportHeader
tih)
      allns :: [Namespace]
allns = forall a. Eq a => [a] -> [a]
nub ((TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ClassImportHeader -> [Namespace]
cihNamespace) forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [Namespace]
tihNamespaces TopLevelImportHeader
tih)
      namespaceStmts :: [CStatement Identity]
namespaceStmts = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). Namespace -> CStatement f
R.UsingNamespace [Namespace]
allns
      aliasStr :: String
aliasStr =
        forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe String
typedefstmt forall a b. (a -> b) -> a -> b
$
            forall a b. [Either a b] -> [b]
rights (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClassImportHeader -> [Either TemplateClass Class]
cihImportedClasses [ClassImportHeader]
cihs forall a. [a] -> [a] -> [a]
++ [Either TemplateClass Class]
extclasses)
        where
          typedefstmt :: Class -> Maybe String
typedefstmt Class
c =
            let n1 :: String
n1 = Class -> String
class_name Class
c
                n2 :: String
n2 = Class -> String
ffiClassName Class
c
             in if String
n1 forall a. Eq a => a -> a -> Bool
== String
n2
                  then forall a. Maybe a
Nothing
                  else forall a. a -> Maybe a
Just (String
"typedef " forall a. Semigroup a => a -> a -> a
<> String
n1 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
n2 forall a. Semigroup a => a -> a -> a
<> String
";")
      declBodyStr :: String
declBodyStr =
        forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (CStatement Identity -> String
R.renderCStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> CStatement Identity
genTopLevelCppDefinition) forall a b. (a -> b) -> a -> b
$
            [TopLevel] -> [TLOrdinary]
filterTLOrdinary (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
   in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        CMacro Identity -> String
R.renderCMacro
        ( [CMacro Identity]
declHeaderStmts
            forall a. Semigroup a => a -> a -> a
<> [forall (f :: * -> *). CMacro f
R.EmptyLine]
            forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
namespaceStmts
            forall a. Semigroup a => a -> a -> a
<> [ forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim String
aliasStr,
                 forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim String
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",
                 forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim
                   String
"#define TYPECASTMETHOD(cname,mname,oname) \\\n\
                   \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\
                   \  (to_nonconst<oname,cname ## _t>), \\\n\
                   \  (to_nonconst<cname,cname ## _t>) )\n",
                 forall (f :: * -> *). CMacro f
R.EmptyLine,
                 forall (f :: * -> *). String -> CMacro f
R.Verbatim String
declBodyStr
               ]
        )

-- |
buildFFIHsc :: ClassModule -> Module ()
buildFFIHsc :: ClassModule -> Module ()
buildFFIHsc ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (String
mname String -> String -> String
<.> String
"FFI")
    [[String] -> ModulePragma ()
lang [String
"ForeignFunctionInterface", String
"InterruptibleFFI"]]
    [ImportDecl ()]
ffiImports
    [Decl ()]
hscBody
  where
    mname :: String
mname = ClassModule -> String
cmModule ClassModule
m
    ffiImports :: [ImportDecl ()]
ffiImports =
      [ String -> ImportDecl ()
mkImport String
"Data.Word",
        String -> ImportDecl ()
mkImport String
"Data.Int",
        String -> ImportDecl ()
mkImport String
"Foreign.C",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport (String
mname String -> String -> String
<.> String
"RawType")
      ]
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInFFI ClassModule
m
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    hscBody :: [Decl ()]
hscBody = ClassImportHeader -> [Decl ()]
genHsFFI (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)

-- |
buildRawTypeHs :: ClassModule -> Module ()
buildRawTypeHs :: ClassModule -> Module ()
buildRawTypeHs ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"RawType")
    [ [String] -> ModulePragma ()
lang
        [ String
"ForeignFunctionInterface",
          String
"TypeFamilies",
          String
"MultiParamTypeClasses",
          String
"FlexibleInstances",
          String
"TypeSynonymInstances",
          String
"EmptyDataDecls",
          String
"ExistentialQuantification",
          String
"ScopedTypeVariables"
        ]
    ]
    [ImportDecl ()]
rawtypeImports
    [Decl ()]
rawtypeBody
  where
    rawtypeImports :: [ImportDecl ()]
rawtypeImports =
      [ String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast"
      ]
    rawtypeBody :: [Decl ()]
rawtypeBody =
      let c :: Class
c = ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)
       in if Class -> Bool
isAbstractClass Class
c then [] else Class -> [Decl ()]
hsClassRawType Class
c

-- |
buildInterfaceHs ::
  AnnotateMap ->
  DepCycles ->
  ClassModule ->
  Module ()
buildInterfaceHs :: AnnotateMap -> DepCycles -> ClassModule -> Module ()
buildInterfaceHs AnnotateMap
amap DepCycles
depCycles ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Interface")
    [ [String] -> ModulePragma ()
lang
        [ String
"EmptyDataDecls",
          String
"ExistentialQuantification",
          String
"FlexibleContexts",
          String
"FlexibleInstances",
          String
"ForeignFunctionInterface",
          String
"MultiParamTypeClasses",
          String
"ScopedTypeVariables",
          String
"TypeFamilies",
          String
"TypeSynonymInstances"
        ]
    ]
    [ImportDecl ()]
ifaceImports
    [Decl ()]
ifaceBody
  where
    classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)]
    ifaceImports :: [ImportDecl ()]
ifaceImports =
      [ String -> ImportDecl ()
mkImport String
"Data.Word",
        String -> ImportDecl ()
mkImport String
"Data.Int",
        String -> ImportDecl ()
mkImport String
"Foreign.C",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast"
      ]
        forall a. Semigroup a => a -> a -> a
<> Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface Bool
False DepCycles
depCycles ClassModule
m
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    ifaceBody :: [Decl ()]
ifaceBody =
      forall r a. Reader r a -> r -> a
runReader (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl Bool
False) [Class]
classes) AnnotateMap
amap
        forall a. Semigroup a => a -> a -> a
<> (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontUpcastClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Bool
isAbstractClass)) [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontDowncastClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Bool
isAbstractClass)) [Class]
classes

-- |
buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module ()
buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module ()
buildInterfaceHsBoot DepCycles
depCycles ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Interface")
    [ [String] -> ModulePragma ()
lang
        [ String
"EmptyDataDecls",
          String
"ExistentialQuantification",
          String
"FlexibleContexts",
          String
"FlexibleInstances",
          String
"ForeignFunctionInterface",
          String
"MultiParamTypeClasses",
          String
"ScopedTypeVariables",
          String
"TypeFamilies",
          String
"TypeSynonymInstances"
        ]
    ]
    [ImportDecl ()]
hsbootImports
    [Decl ()]
hsbootBody
  where
    c :: Class
c = ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)
    hsbootImports :: [ImportDecl ()]
hsbootImports =
      [ String -> ImportDecl ()
mkImport String
"Data.Word",
        String -> ImportDecl ()
mkImport String
"Data.Int",
        String -> ImportDecl ()
mkImport String
"Foreign.C",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast"
      ]
        forall a. Semigroup a => a -> a -> a
<> Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface Bool
True DepCycles
depCycles ClassModule
m
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    hsbootBody :: [Decl ()]
hsbootBody =
      forall r a. Reader r a -> r -> a
runReader (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl Bool
True) [Class
c]) forall k a. Map k a
M.empty

-- |
buildCastHs :: ClassModule -> Module ()
buildCastHs :: ClassModule -> Module ()
buildCastHs ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Cast")
    [ [String] -> ModulePragma ()
lang
        [ String
"FlexibleInstances",
          String
"FlexibleContexts",
          String
"TypeFamilies",
          String
"MultiParamTypeClasses",
          String
"OverlappingInstances",
          String
"IncoherentInstances"
        ]
    ]
    [ImportDecl ()]
castImports
    [Decl ()]
body
  where
    classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)]
    castImports :: [ImportDecl ()]
castImports =
      [ String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast",
        String -> ImportDecl ()
mkImport String
"System.IO.Unsafe"
      ]
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInCast ClassModule
m
    body :: [Decl ()]
body =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe (Decl ())
genHsFrontInstCastable [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe (Decl ())
genHsFrontInstCastableSelf [Class]
classes

-- |
buildImplementationHs :: AnnotateMap -> ClassModule -> Module ()
buildImplementationHs :: AnnotateMap -> ClassModule -> Module ()
buildImplementationHs AnnotateMap
amap ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Implementation")
    [ [String] -> ModulePragma ()
lang
        [ String
"EmptyDataDecls",
          String
"FlexibleContexts",
          String
"FlexibleInstances",
          String
"ForeignFunctionInterface",
          String
"IncoherentInstances",
          String
"MultiParamTypeClasses",
          String
"OverlappingInstances",
          String
"TemplateHaskell",
          String
"TypeFamilies",
          String
"TypeSynonymInstances"
        ]
    ]
    [ImportDecl ()]
implImports
    [Decl ()]
implBody
  where
    classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)]
    implImports :: [ImportDecl ()]
implImports =
      [ String -> ImportDecl ()
mkImport String
"Data.Monoid", -- for template member
        String -> ImportDecl ()
mkImport String
"Data.Word",
        String -> ImportDecl ()
mkImport String
"Data.Int",
        String -> ImportDecl ()
mkImport String
"Foreign.C",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH", -- for template member
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH.Syntax", -- for template member
        String -> ImportDecl ()
mkImport String
"System.IO.Unsafe",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.CodeGen.Cxx", -- for template member
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.TH" -- for template member
      ]
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInImplementation ClassModule
m
        forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    f :: Class -> [Decl ()]
    f :: Class -> [Decl ()]
f Class
y = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip Class -> Class -> [Decl ()]
genHsFrontInst Class
y) (Class
y forall a. a -> [a] -> [a]
: Class -> [Class]
class_allparents Class
y)
    implBody :: [Decl ()]
implBody =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
f [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> forall r a. Reader r a -> r -> a
runReader (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Class -> ReaderT AnnotateMap Identity [Decl ()]
genHsFrontInstNew [Class]
classes) AnnotateMap
amap
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstNonVirtual [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstStatic [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstVariables [Class]
classes
        forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> [Decl ()]
genTemplateMemberFunctions (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)

buildProxyHs :: ClassModule -> Module ()
buildProxyHs :: ClassModule -> Module ()
buildProxyHs ClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Proxy")
    [ [String] -> ModulePragma ()
lang
        [ String
"FlexibleInstances",
          String
"OverloadedStrings",
          String
"TemplateHaskell"
        ]
    ]
    [ String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
      String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast",
      String -> ImportDecl ()
mkImport String
"Language.Haskell.TH",
      String -> ImportDecl ()
mkImport String
"Language.Haskell.TH.Syntax",
      String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.CodeGen.Cxx"
    ]
    [Decl ()]
body
  where
    body :: [Decl ()]
body = [Decl ()]
genProxyInstance

buildTemplateHs :: TemplateClassModule -> Module ()
buildTemplateHs :: TemplateClassModule -> Module ()
buildTemplateHs TemplateClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (TemplateClassModule -> String
tcmModule TemplateClassModule
m String -> String -> String
<.> String
"Template")
    [ [String] -> ModulePragma ()
lang
        [ String
"EmptyDataDecls",
          String
"FlexibleInstances",
          String
"MultiParamTypeClasses",
          String
"TypeFamilies"
        ]
    ]
    [ImportDecl ()]
imports
    [Decl ()]
body
  where
    t :: TemplateClass
t = TemplateClassImportHeader -> TemplateClass
tcihTClass forall a b. (a -> b) -> a -> b
$ TemplateClassModule -> TemplateClassImportHeader
tcmTCIH TemplateClassModule
m
    imports :: [ImportDecl ()]
imports =
      [ String -> ImportDecl ()
mkImport String
"Foreign.C.Types",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast"
      ]
        forall a. Semigroup a => a -> a -> a
<> TemplateClass -> [ImportDecl ()]
genImportInTemplate TemplateClass
t
    body :: [Decl ()]
body = TemplateClass -> [Decl ()]
genTmplInterface TemplateClass
t

buildTHHs :: TemplateClassModule -> Module ()
buildTHHs :: TemplateClassModule -> Module ()
buildTHHs TemplateClassModule
m =
  String
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (TemplateClassModule -> String
tcmModule TemplateClassModule
m String -> String -> String
<.> String
"TH")
    [[String] -> ModulePragma ()
lang [String
"TemplateHaskell"]]
    ( [ String -> ImportDecl ()
mkImport String
"Data.Char",
        String -> ImportDecl ()
mkImport String
"Data.List",
        String -> ImportDecl ()
mkImport String
"Data.Monoid",
        String -> ImportDecl ()
mkImport String
"Foreign.C.Types",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH",
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH.Syntax",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.CodeGen.Cxx",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.TH"
      ]
        forall a. Semigroup a => a -> a -> a
<> [ImportDecl ()]
imports
    )
    [Decl ()]
body
  where
    t :: TemplateClass
t = TemplateClassImportHeader -> TemplateClass
tcihTClass forall a b. (a -> b) -> a -> b
$ TemplateClassModule -> TemplateClassImportHeader
tcmTCIH TemplateClassModule
m
    imports :: [ImportDecl ()]
imports =
      [String -> ImportDecl ()
mkImport (TemplateClassModule -> String
tcmModule TemplateClassModule
m String -> String -> String
<.> String
"Template")]
        forall a. Semigroup a => a -> a -> a
<> TemplateClass -> [ImportDecl ()]
genImportInTH TemplateClass
t
    body :: [Decl ()]
body = [Decl ()]
tmplImpls forall a. Semigroup a => a -> a -> a
<> [Decl ()]
tmplInsts
    tmplImpls :: [Decl ()]
tmplImpls = TemplateClass -> [Decl ()]
genTmplImplementation TemplateClass
t
    tmplInsts :: [Decl ()]
tmplInsts = TemplateClassImportHeader -> [Decl ()]
genTmplInstance (TemplateClassModule -> TemplateClassImportHeader
tcmTCIH TemplateClassModule
m)

-- |
buildModuleHs :: ClassModule -> Module ()
buildModuleHs :: ClassModule -> Module ()
buildModuleHs ClassModule
m = String
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE (ClassModule -> String
cmModule ClassModule
m) [] (Class -> [ExportSpec ()]
genExport Class
c) (Class -> [ImportDecl ()]
genImportInModule Class
c) []
  where
    c :: Class
c = ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)

-- |
buildTopLevelHs ::
  String ->
  ([ClassModule], [TemplateClassModule]) ->
  Module ()
buildTopLevelHs :: String -> ([ClassModule], [TemplateClassModule]) -> Module ()
buildTopLevelHs String
modname ([ClassModule]
mods, [TemplateClassModule]
tmods) =
  String
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE String
modname [ModulePragma ()]
pkgExtensions [ExportSpec ()]
pkgExports [ImportDecl ()]
pkgImports forall a. [a]
pkgBody
  where
    pkgExtensions :: [ModulePragma ()]
pkgExtensions =
      [ [String] -> ModulePragma ()
lang
          [ String
"FlexibleContexts",
            String
"FlexibleInstances",
            String
"ForeignFunctionInterface",
            String
"InterruptibleFFI"
          ]
      ]
    pkgExports :: [ExportSpec ()]
pkgExports =
      forall a b. (a -> b) -> [a] -> [b]
map (String -> ExportSpec ()
emodule forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> String
cmModule) [ClassModule]
mods
        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> ExportSpec ()
emodule [String
modname String -> String -> String
<.> String
"Ordinary", String
modname String -> String -> String
<.> String
"Template", String
modname String -> String -> String
<.> String
"TH"]
    pkgImports :: [ImportDecl ()]
pkgImports = String -> ([ClassModule], [TemplateClassModule]) -> [ImportDecl ()]
genImportInTopLevel String
modname ([ClassModule]
mods, [TemplateClassModule]
tmods)
    pkgBody :: [a]
pkgBody = [] --    map (genTopLevelFFI tih) (filterTLOrdinary tfns)
    -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns)

buildTopLevelOrdinaryHs ::
  String ->
  ([ClassModule], [TemplateClassModule]) ->
  TopLevelImportHeader ->
  Module ()
buildTopLevelOrdinaryHs :: String
-> ([ClassModule], [TemplateClassModule])
-> TopLevelImportHeader
-> Module ()
buildTopLevelOrdinaryHs String
modname ([ClassModule]
_mods, [TemplateClassModule]
tmods) TopLevelImportHeader
tih =
  String
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE String
modname [ModulePragma ()]
pkgExtensions [ExportSpec ()]
pkgExports [ImportDecl ()]
pkgImports [Decl ()]
pkgBody
  where
    tfns :: [TopLevel]
tfns = TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih
    pkgExtensions :: [ModulePragma ()]
pkgExtensions =
      [ [String] -> ModulePragma ()
lang
          [ String
"FlexibleContexts",
            String
"FlexibleInstances",
            String
"ForeignFunctionInterface",
            String
"InterruptibleFFI"
          ]
      ]
    pkgExports :: [ExportSpec ()]
pkgExports = forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> TopLevel
TLOrdinary) ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
    pkgImports :: [ImportDecl ()]
pkgImports =
      forall a b. (a -> b) -> [a] -> [b]
map String -> ImportDecl ()
mkImport [String
"Foreign.C", String
"Foreign.Ptr", String
"FFICXX.Runtime.Cast"]
        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\TemplateClassModule
m -> String -> ImportDecl ()
mkImport (TemplateClassModule -> String
tcmModule TemplateClassModule
m String -> String -> String
<.> String
"Template")) [TemplateClassModule]
tmods
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLOrdinary -> [ImportDecl ()]
genImportForTLOrdinary ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
    pkgBody :: [Decl ()]
pkgBody =
      forall a b. (a -> b) -> [a] -> [b]
map (TopLevelImportHeader -> TLOrdinary -> Decl ()
genTopLevelFFI TopLevelImportHeader
tih) ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLOrdinary -> [Decl ()]
genTopLevelDef ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)

-- |
buildTopLevelTemplateHs ::
  String ->
  TopLevelImportHeader ->
  Module ()
buildTopLevelTemplateHs :: String -> TopLevelImportHeader -> Module ()
buildTopLevelTemplateHs String
modname TopLevelImportHeader
tih =
  String
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE String
modname [ModulePragma ()]
pkgExtensions [ExportSpec ()]
pkgExports [ImportDecl ()]
pkgImports [Decl ()]
pkgBody
  where
    tfns :: [TLTemplate]
tfns = [TopLevel] -> [TLTemplate]
filterTLTemplate (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
    pkgExtensions :: [ModulePragma ()]
pkgExtensions =
      [ [String] -> ModulePragma ()
lang
          [ String
"EmptyDataDecls",
            String
"FlexibleInstances",
            String
"ForeignFunctionInterface",
            String
"InterruptibleFFI",
            String
"MultiParamTypeClasses",
            String
"TypeFamilies"
          ]
      ]
    pkgExports :: [ExportSpec ()]
pkgExports =
      forall a b. (a -> b) -> [a] -> [b]
map
        ( (\QName ()
n -> forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith () (forall l. l -> Int -> EWildcard l
EWildcard () Int
1) QName ()
n [])
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
firstUpper
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLTemplate -> TopLevel
TLTemplate
        )
        [TLTemplate]
tfns
    pkgImports :: [ImportDecl ()]
pkgImports =
      [ String -> ImportDecl ()
mkImport String
"Foreign.C.Types",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.Cast"
      ]
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [ImportDecl ()]
genImportForTLTemplate [TLTemplate]
tfns
    pkgBody :: [Decl ()]
pkgBody = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [Decl ()]
genTLTemplateInterface [TLTemplate]
tfns

-- |
buildTopLevelTHHs ::
  String ->
  TopLevelImportHeader ->
  Module ()
buildTopLevelTHHs :: String -> TopLevelImportHeader -> Module ()
buildTopLevelTHHs String
modname TopLevelImportHeader
tih =
  String
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE String
modname [ModulePragma ()]
pkgExtensions [ExportSpec ()]
pkgExports [ImportDecl ()]
pkgImports [Decl ()]
pkgBody
  where
    tfns :: [TLTemplate]
tfns = [TopLevel] -> [TLTemplate]
filterTLTemplate (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
    pkgExtensions :: [ModulePragma ()]
pkgExtensions =
      [ [String] -> ModulePragma ()
lang
          [ String
"FlexibleContexts",
            String
"FlexibleInstances",
            String
"ForeignFunctionInterface",
            String
"InterruptibleFFI",
            String
"TemplateHaskell"
          ]
      ]
    pkgExports :: [ExportSpec ()]
pkgExports =
      forall a b. (a -> b) -> [a] -> [b]
map
        ( QName () -> ExportSpec ()
evar
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
x -> String
"gen" forall a. Semigroup a => a -> a -> a
<> String
x forall a. Semigroup a => a -> a -> a
<> String
"InstanceFor")
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
firstUpper
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLTemplate -> TopLevel
TLTemplate
        )
        [TLTemplate]
tfns
    pkgImports :: [ImportDecl ()]
pkgImports =
      [ String -> ImportDecl ()
mkImport String
"Data.Char",
        String -> ImportDecl ()
mkImport String
"Data.List",
        String -> ImportDecl ()
mkImport String
"Data.Monoid",
        String -> ImportDecl ()
mkImport String
"Foreign.C.Types",
        String -> ImportDecl ()
mkImport String
"Foreign.Ptr",
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH",
        String -> ImportDecl ()
mkImport String
"Language.Haskell.TH.Syntax",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.CodeGen.Cxx",
        String -> ImportDecl ()
mkImport String
"FFICXX.Runtime.TH"
      ]
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [ImportDecl ()]
genImportForTLTemplate [TLTemplate]
tfns
    pkgBody :: [Decl ()]
pkgBody =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [Decl ()]
genTLTemplateImplementation [TLTemplate]
tfns
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TopLevelImportHeader -> TLTemplate -> [Decl ()]
genTLTemplateInstance TopLevelImportHeader
tih) [TLTemplate]
tfns

-- |
buildPackageInterface ::
  PackageInterface ->
  PackageName ->
  [ClassImportHeader] ->
  PackageInterface
buildPackageInterface :: PackageInterface
-> PackageName -> [ClassImportHeader] -> PackageInterface
buildPackageInterface PackageInterface
pinfc PackageName
pkgname = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ClassImportHeader -> PackageInterface -> PackageInterface
f PackageInterface
pinfc
  where
    f :: ClassImportHeader -> PackageInterface -> PackageInterface
f ClassImportHeader
cih PackageInterface
repo =
      let name :: String
name = (Class -> String
class_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassImportHeader -> Class
cihClass) ClassImportHeader
cih
          header :: HeaderName
header = ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
cih
       in PackageInterface
repo forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (PackageName
pkgname, String -> ClassName
ClsName String
name) forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. a -> Maybe a
Just HeaderName
header)