{-# 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 (DaughterMap -> DaughterMap -> ClassGlobal)
-> ([Class] -> DaughterMap)
-> [Class]
-> DaughterMap
-> ClassGlobal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Class] -> DaughterMap
mkDaughterSelfMap ([Class] -> DaughterMap -> ClassGlobal)
-> ([Class] -> DaughterMap) -> [Class] -> ClassGlobal
forall a b. ([Class] -> a -> b) -> ([Class] -> a) -> [Class] -> b
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 = DaughterMap -> [(String, [Class])]
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, (Class -> Bool) -> [Class] -> [Class]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Bool
isAbstractClass) [Class]
xs)
   in (((String, [Class]) -> String) -> [(String, [Class])] -> String
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 = (Class -> [CStatement Identity])
-> [Class] -> [CStatement Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
p -> (Class, Class) -> [CStatement Identity]
f (Class
p, Class
cls)) ([Class] -> [CStatement Identity])
-> (Class -> [Class]) -> Class -> [CStatement Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Class]
class_allparents (Class -> [CStatement Identity]) -> Class -> [CStatement Identity]
forall a b. (a -> b) -> a -> b
$ Class
cls

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

-- |
buildTypeDeclHeader ::
  [Class] ->
  String
buildTypeDeclHeader :: [Class] -> String
buildTypeDeclHeader [Class]
classes =
  let typeDeclBodyStmts :: [CMacro Identity]
typeDeclBodyStmts =
        [CMacro Identity] -> [[CMacro Identity]] -> [CMacro Identity]
forall a. [a] -> [[a]] -> [a]
intercalate [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine] ([[CMacro Identity]] -> [CMacro Identity])
-> [[CMacro Identity]] -> [CMacro Identity]
forall a b. (a -> b) -> a -> b
$
          (Class -> [CMacro Identity]) -> [Class] -> [[CMacro Identity]]
forall a b. (a -> b) -> [a] -> [b]
map ((CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map CStatement Identity -> CMacro Identity
forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular ([CStatement Identity] -> [CMacro Identity])
-> (Class -> [CStatement Identity]) -> Class -> [CMacro Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [CStatement Identity]
genCppHeaderMacroType) [Class]
classes
   in CBlock Identity -> String
R.renderBlock (CBlock Identity -> String) -> CBlock Identity -> String
forall a b. (a -> b) -> a -> b
$
        [CMacro Identity] -> CBlock Identity
forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC ([CMacro Identity] -> CBlock Identity)
-> [CMacro Identity] -> CBlock Identity
forall a b. (a -> b) -> a -> b
$
          [PragmaParam -> CMacro Identity
forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine] [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
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 =
        [HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (String
cprefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Type.h"))]
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (HeaderName -> CMacro Identity)
-> [HeaderName] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (ClassImportHeader -> [HeaderName]
cihIncludedHPkgHeadersInH ClassImportHeader
header)
      vdecl :: [CMacro Identity]
vdecl = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroVirtual [Class]
classes
      nvdecl :: [CMacro Identity]
nvdecl = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroNonVirtual [Class]
classes
      acdecl :: [CMacro Identity]
acdecl = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppHeaderMacroAccessor [Class]
classes
      vdef :: [CMacro Identity]
vdef = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroVirtual [Class]
classes
      nvdef :: [CMacro Identity]
nvdef = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroNonVirtual [Class]
classes
      acdef :: [CMacro Identity]
acdef = (Class -> CMacro Identity) -> [Class] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map Class -> CMacro Identity
genCppDefMacroAccessor [Class]
classes
      tmpldef :: [[CMacro Identity]]
tmpldef = (Class -> [CMacro Identity]) -> [Class] -> [[CMacro Identity]]
forall a b. (a -> b) -> [a] -> [b]
map (\Class
c -> (TemplateMemberFunction -> CMacro Identity)
-> [TemplateMemberFunction] -> [CMacro Identity]
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 =
        [CMacro Identity] -> [[CMacro Identity]] -> [CMacro Identity]
forall a. [a] -> [[a]] -> [a]
intercalate [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine] ([[CMacro Identity]] -> [CMacro Identity])
-> [[CMacro Identity]] -> [CMacro Identity]
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] [[CMacro Identity]] -> [[CMacro Identity]] -> [[CMacro Identity]]
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 ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (Class -> (String, String)) -> Class -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> (String, String)
hsClassName) Class
aclass String -> String -> Bool
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), CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) Class
aclass
              [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> [(Class, Class) -> CStatement Identity
genCppHeaderInstVirtual (Class
aclass, Class
aclass), CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]
              [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> (Class -> [CStatement Identity])
-> [Class] -> [CStatement Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppHeaderInstNonVirtual Class
c, CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
              [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> (Class -> [CStatement Identity])
-> [Class] -> [CStatement Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppHeaderInstAccessor Class
c, CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
          else []
   in CBlock Identity -> String
R.renderBlock (CBlock Identity -> String) -> CBlock Identity -> String
forall a b. (a -> b) -> a -> b
$
        [CMacro Identity] -> CBlock Identity
forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC ([CMacro Identity] -> CBlock Identity)
-> [CMacro Identity] -> CBlock Identity
forall a b. (a -> b) -> a -> b
$
          [PragmaParam -> CMacro Identity
forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declHeaderStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declDefStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map CStatement Identity -> CMacro Identity
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 =
        [HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include HeaderName
"MacroPatternMatch.h"]
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> ClassImportHeader -> [CMacro Identity]
genAllCppHeaderInclude ClassImportHeader
cih
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
cih)]
      namespaceStmts :: [CStatement Identity]
namespaceStmts =
        ((Namespace -> CStatement Identity)
-> [Namespace] -> [CStatement Identity]
forall a b. (a -> b) -> [a] -> [b]
map Namespace -> CStatement Identity
forall (f :: * -> *). Namespace -> CStatement f
R.UsingNamespace ([Namespace] -> [CStatement Identity])
-> (ClassImportHeader -> [Namespace])
-> ClassImportHeader
-> [CStatement Identity]
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 =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          (Class -> Maybe String) -> [Class] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe String
typedefstmt ([Class] -> [String]) -> [Class] -> [String]
forall a b. (a -> b) -> a -> b
$
            Class
aclass Class -> [Class] -> [Class]
forall a. a -> [a] -> [a]
: [Either TemplateClass Class] -> [Class]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2
                  then Maybe String
forall a. Maybe a
Nothing
                  else String -> Maybe String
forall a. a -> Maybe a
Just (String
"typedef " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";")
      cppBodyStmts :: [CMacro Identity]
cppBodyStmts =
        Class -> [CMacro Identity]
mkProtectedFunctionList (ClassImportHeader -> Class
cihClass ClassImportHeader
cih)
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map
            CStatement Identity -> CMacro Identity
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), CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) (ClassImportHeader -> Class
cihClass ClassImportHeader
cih)
                [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> ( if Class -> Bool
isAbstractClass Class
aclass
                       then []
                       else [(Class, Class) -> CStatement Identity
genCppDefInstVirtual (Class
aclass, Class
aclass), CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]
                   )
                [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> (Class -> [CStatement Identity])
-> [Class] -> [CStatement Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppDefInstNonVirtual Class
c, CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
                [CStatement Identity]
-> [CStatement Identity] -> [CStatement Identity]
forall a. Semigroup a => a -> a -> a
<> (Class -> [CStatement Identity])
-> [Class] -> [CStatement Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Class
c -> [Class -> CStatement Identity
genCppDefInstAccessor Class
c, CStatement Identity
forall (f :: * -> *). CStatement f
R.CEmptyLine]) [Class]
classes
            )
   in (CMacro Identity -> String) -> [CMacro Identity] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        CMacro Identity -> String
R.renderCMacro
        ( [CMacro Identity]
headerStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map CStatement Identity -> CMacro Identity
forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
namespaceStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [ CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
forall (f :: * -> *). String -> CMacro f
R.Verbatim String
aliasStr,
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
forall (f :: * -> *). String -> CMacro f
R.Verbatim String
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
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",
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine
               ]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
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 =
        [HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (String
cprefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Type.h"))]
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (HeaderName -> CMacro Identity)
-> [HeaderName] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include ((ClassImportHeader -> HeaderName)
-> [ClassImportHeader] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map ClassImportHeader -> HeaderName
cihSelfHeader (TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih) [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [HeaderName]
tihExtraHeadersInH TopLevelImportHeader
tih)
      declBodyStmts :: [CStatement Identity]
declBodyStmts = (TLOrdinary -> CStatement Identity)
-> [TLOrdinary] -> [CStatement Identity]
forall a b. (a -> b) -> [a] -> [b]
map (CFunDecl Identity -> CStatement Identity
forall (f :: * -> *). CFunDecl f -> CStatement f
R.CDeclaration (CFunDecl Identity -> CStatement Identity)
-> (TLOrdinary -> CFunDecl Identity)
-> TLOrdinary
-> CStatement Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> CFunDecl Identity
topLevelDecl) ([TLOrdinary] -> [CStatement Identity])
-> [TLOrdinary] -> [CStatement Identity]
forall a b. (a -> b) -> a -> b
$ [TopLevel] -> [TLOrdinary]
filterTLOrdinary (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
   in CBlock Identity -> String
R.renderBlock (CBlock Identity -> String) -> CBlock Identity -> String
forall a b. (a -> b) -> a -> b
$
        [CMacro Identity] -> CBlock Identity
forall (f :: * -> *). [CMacro f] -> CBlock f
R.ExternC ([CMacro Identity] -> CBlock Identity)
-> [CMacro Identity] -> CBlock Identity
forall a b. (a -> b) -> a -> b
$
          [PragmaParam -> CMacro Identity
forall (f :: * -> *). PragmaParam -> CMacro f
R.Pragma PragmaParam
R.Once, CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
declHeaderStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map CStatement Identity -> CMacro Identity
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 =
        [ HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include HeaderName
"MacroPatternMatch.h",
          HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (String -> HeaderName
HdrName (TopLevelImportHeader -> String
tihHeaderFileName TopLevelImportHeader
tih String -> String -> String
<.> String
"h"))
        ]
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (ClassImportHeader -> [CMacro Identity])
-> [ClassImportHeader] -> [CMacro Identity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClassImportHeader -> [CMacro Identity]
genAllCppHeaderInclude [ClassImportHeader]
cihs
          [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity]
otherHeaderStmts
      otherHeaderStmts :: [CMacro Identity]
otherHeaderStmts =
        (HeaderName -> CMacro Identity)
-> [HeaderName] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include ((ClassImportHeader -> HeaderName)
-> [ClassImportHeader] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map ClassImportHeader -> HeaderName
cihSelfHeader [ClassImportHeader]
cihs [HeaderName] -> [HeaderName] -> [HeaderName]
forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [HeaderName]
tihExtraHeadersInCPP TopLevelImportHeader
tih)
      allns :: [Namespace]
allns = [Namespace] -> [Namespace]
forall a. Eq a => [a] -> [a]
nub ((TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih [ClassImportHeader]
-> (ClassImportHeader -> [Namespace]) -> [Namespace]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ClassImportHeader -> [Namespace]
cihNamespace) [Namespace] -> [Namespace] -> [Namespace]
forall a. [a] -> [a] -> [a]
++ TopLevelImportHeader -> [Namespace]
tihNamespaces TopLevelImportHeader
tih)
      namespaceStmts :: [CStatement Identity]
namespaceStmts = (Namespace -> CStatement Identity)
-> [Namespace] -> [CStatement Identity]
forall a b. (a -> b) -> [a] -> [b]
map Namespace -> CStatement Identity
forall (f :: * -> *). Namespace -> CStatement f
R.UsingNamespace [Namespace]
allns
      aliasStr :: String
aliasStr =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          (Class -> Maybe String) -> [Class] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe String
typedefstmt ([Class] -> [String]) -> [Class] -> [String]
forall a b. (a -> b) -> a -> b
$
            [Either TemplateClass Class] -> [Class]
forall a b. [Either a b] -> [b]
rights ((ClassImportHeader -> [Either TemplateClass Class])
-> [ClassImportHeader] -> [Either TemplateClass Class]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClassImportHeader -> [Either TemplateClass Class]
cihImportedClasses [ClassImportHeader]
cihs [Either TemplateClass Class]
-> [Either TemplateClass Class] -> [Either TemplateClass Class]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2
                  then Maybe String
forall a. Maybe a
Nothing
                  else String -> Maybe String
forall a. a -> Maybe a
Just (String
"typedef " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";")
      declBodyStr :: String
declBodyStr =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          (TLOrdinary -> String) -> [TLOrdinary] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CStatement Identity -> String
R.renderCStmt (CStatement Identity -> String)
-> (TLOrdinary -> CStatement Identity) -> TLOrdinary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> CStatement Identity
genTopLevelCppDefinition) ([TLOrdinary] -> [String]) -> [TLOrdinary] -> [String]
forall a b. (a -> b) -> a -> b
$
            [TopLevel] -> [TLOrdinary]
filterTLOrdinary (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)
   in (CMacro Identity -> String) -> [CMacro Identity] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        CMacro Identity -> String
R.renderCMacro
        ( [CMacro Identity]
declHeaderStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine]
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> (CStatement Identity -> CMacro Identity)
-> [CStatement Identity] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map CStatement Identity -> CMacro Identity
forall (f :: * -> *). CStatement f -> CMacro f
R.CRegular [CStatement Identity]
namespaceStmts
            [CMacro Identity] -> [CMacro Identity] -> [CMacro Identity]
forall a. Semigroup a => a -> a -> a
<> [ CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
forall (f :: * -> *). String -> CMacro f
R.Verbatim String
aliasStr,
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
forall (f :: * -> *). String -> CMacro f
R.Verbatim String
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
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",
                 CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine,
                 String -> CMacro Identity
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")
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInFFI ClassModule
m
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface Bool
False DepCycles
depCycles ClassModule
m
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    ifaceBody :: [Decl ()]
ifaceBody =
      Reader AnnotateMap [Decl ()] -> AnnotateMap -> [Decl ()]
forall r a. Reader r a -> r -> a
runReader ((Class -> ReaderT AnnotateMap Identity (Decl ()))
-> [Class] -> Reader AnnotateMap [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> Class -> ReaderT AnnotateMap Identity (Decl ())
genHsFrontDecl Bool
False) [Class]
classes) AnnotateMap
amap
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> ((Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontUpcastClass ([Class] -> [Decl ()])
-> ([Class] -> [Class]) -> [Class] -> [Decl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Class -> Bool) -> [Class] -> [Class]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Bool
isAbstractClass)) [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> ((Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontDowncastClass ([Class] -> [Decl ()])
-> ([Class] -> [Class]) -> [Class] -> [Decl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Class -> Bool) -> [Class] -> [Class]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface Bool
True DepCycles
depCycles ClassModule
m
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    hsbootBody :: [Decl ()]
hsbootBody =
      Reader AnnotateMap [Decl ()] -> AnnotateMap -> [Decl ()]
forall r a. Reader r a -> r -> a
runReader ((Class -> ReaderT AnnotateMap Identity (Decl ()))
-> [Class] -> Reader AnnotateMap [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> Class -> ReaderT AnnotateMap Identity (Decl ())
genHsFrontDecl Bool
True) [Class
c]) AnnotateMap
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInCast ClassModule
m
    body :: [Decl ()]
body =
      (Class -> Maybe (Decl ())) -> [Class] -> [Decl ()]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe (Decl ())
genHsFrontInstCastable [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (Class -> Maybe (Decl ())) -> [Class] -> [Decl ()]
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
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInImplementation ClassModule
m
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
m
    f :: Class -> [Decl ()]
    f :: Class -> [Decl ()]
f Class
y = (Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Class -> Class -> [Decl ()]) -> Class -> Class -> [Decl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Class -> Class -> [Decl ()]
genHsFrontInst Class
y) (Class
y Class -> [Class] -> [Class]
forall a. a -> [a] -> [a]
: Class -> [Class]
class_allparents Class
y)
    implBody :: [Decl ()]
implBody =
      (Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
f [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> Reader AnnotateMap [Decl ()] -> AnnotateMap -> [Decl ()]
forall r a. Reader r a -> r -> a
runReader ([[Decl ()]] -> [Decl ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Decl ()]] -> [Decl ()])
-> ReaderT AnnotateMap Identity [[Decl ()]]
-> Reader AnnotateMap [Decl ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Class -> Reader AnnotateMap [Decl ()])
-> [Class] -> ReaderT AnnotateMap Identity [[Decl ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Class -> Reader AnnotateMap [Decl ()]
genHsFrontInstNew [Class]
classes) AnnotateMap
amap
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstNonVirtual [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstStatic [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (Class -> [Decl ()]) -> [Class] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> [Decl ()]
genHsFrontInstVariables [Class]
classes
        [Decl ()] -> [Decl ()] -> [Decl ()]
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 (TemplateClassImportHeader -> TemplateClass)
-> TemplateClassImportHeader -> TemplateClass
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> [ImportDecl ()]
imports
    )
    [Decl ()]
body
  where
    t :: TemplateClass
t = TemplateClassImportHeader -> TemplateClass
tcihTClass (TemplateClassImportHeader -> TemplateClass)
-> TemplateClassImportHeader -> TemplateClass
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")]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> TemplateClass -> [ImportDecl ()]
genImportInTH TemplateClass
t
    body :: [Decl ()]
body = [Decl ()]
tmplImpls [Decl ()] -> [Decl ()] -> [Decl ()]
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 [Decl ()]
forall a. [a]
pkgBody
  where
    pkgExtensions :: [ModulePragma ()]
pkgExtensions =
      [ [String] -> ModulePragma ()
lang
          [ String
"FlexibleContexts",
            String
"FlexibleInstances",
            String
"ForeignFunctionInterface",
            String
"InterruptibleFFI"
          ]
      ]
    pkgExports :: [ExportSpec ()]
pkgExports =
      (ClassModule -> ExportSpec ()) -> [ClassModule] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ExportSpec ()
emodule (String -> ExportSpec ())
-> (ClassModule -> String) -> ClassModule -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> String
cmModule) [ClassModule]
mods
        [ExportSpec ()] -> [ExportSpec ()] -> [ExportSpec ()]
forall a. [a] -> [a] -> [a]
++ (String -> ExportSpec ()) -> [String] -> [ExportSpec ()]
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 = (TLOrdinary -> ExportSpec ()) -> [TLOrdinary] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar (QName () -> ExportSpec ())
-> (TLOrdinary -> QName ()) -> TLOrdinary -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual (String -> QName ())
-> (TLOrdinary -> String) -> TLOrdinary -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel (TopLevel -> String)
-> (TLOrdinary -> TopLevel) -> TLOrdinary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLOrdinary -> TopLevel
TLOrdinary) ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
    pkgImports :: [ImportDecl ()]
pkgImports =
      (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> ImportDecl ()
mkImport [String
"Foreign.C", String
"Foreign.Ptr", String
"FFICXX.Runtime.Cast"]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. [a] -> [a] -> [a]
++ (TemplateClassModule -> ImportDecl ())
-> [TemplateClassModule] -> [ImportDecl ()]
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
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. [a] -> [a] -> [a]
++ (TLOrdinary -> [ImportDecl ()]) -> [TLOrdinary] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLOrdinary -> [ImportDecl ()]
genImportForTLOrdinary ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
    pkgBody :: [Decl ()]
pkgBody =
      (TLOrdinary -> Decl ()) -> [TLOrdinary] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (TopLevelImportHeader -> TLOrdinary -> Decl ()
genTopLevelFFI TopLevelImportHeader
tih) ([TopLevel] -> [TLOrdinary]
filterTLOrdinary [TopLevel]
tfns)
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ (TLOrdinary -> [Decl ()]) -> [TLOrdinary] -> [Decl ()]
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 =
      (TLTemplate -> ExportSpec ()) -> [TLTemplate] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map
        ( (\QName ()
n -> () -> EWildcard () -> QName () -> [CName ()] -> ExportSpec ()
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith () (() -> Int -> EWildcard ()
forall l. l -> Int -> EWildcard l
EWildcard () Int
1) QName ()
n [])
            (QName () -> ExportSpec ())
-> (TLTemplate -> QName ()) -> TLTemplate -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual
            (String -> QName ())
-> (TLTemplate -> String) -> TLTemplate -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
firstUpper
            (String -> String)
-> (TLTemplate -> String) -> TLTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel
            (TopLevel -> String)
-> (TLTemplate -> TopLevel) -> TLTemplate -> String
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. [a] -> [a] -> [a]
++ (TLTemplate -> [ImportDecl ()]) -> [TLTemplate] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [ImportDecl ()]
genImportForTLTemplate [TLTemplate]
tfns
    pkgBody :: [Decl ()]
pkgBody = (TLTemplate -> [Decl ()]) -> [TLTemplate] -> [Decl ()]
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 =
      (TLTemplate -> ExportSpec ()) -> [TLTemplate] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map
        ( QName () -> ExportSpec ()
evar
            (QName () -> ExportSpec ())
-> (TLTemplate -> QName ()) -> TLTemplate -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual
            (String -> QName ())
-> (TLTemplate -> String) -> TLTemplate -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
x -> String
"gen" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"InstanceFor")
            (String -> String)
-> (TLTemplate -> String) -> TLTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
firstUpper
            (String -> String)
-> (TLTemplate -> String) -> TLTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> String
hsFrontNameForTopLevel
            (TopLevel -> String)
-> (TLTemplate -> TopLevel) -> TLTemplate -> String
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"
      ]
        [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. [a] -> [a] -> [a]
++ (TLTemplate -> [ImportDecl ()]) -> [TLTemplate] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [ImportDecl ()]
genImportForTLTemplate [TLTemplate]
tfns
    pkgBody :: [Decl ()]
pkgBody =
      (TLTemplate -> [Decl ()]) -> [TLTemplate] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TLTemplate -> [Decl ()]
genTLTemplateImplementation [TLTemplate]
tfns
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (TLTemplate -> [Decl ()]) -> [TLTemplate] -> [Decl ()]
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 = (ClassImportHeader -> PackageInterface -> PackageInterface)
-> PackageInterface -> [ClassImportHeader] -> PackageInterface
forall a b. (a -> b -> b) -> b -> [a] -> b
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 (Class -> String)
-> (ClassImportHeader -> Class) -> ClassImportHeader -> String
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 PackageInterface
-> (PackageInterface -> PackageInterface) -> PackageInterface
forall a b. a -> (a -> b) -> b
& Index PackageInterface
-> Lens' PackageInterface (Maybe (IxValue PackageInterface))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (PackageName
pkgname, String -> ClassName
ClsName String
name) ((Maybe HeaderName -> Identity (Maybe HeaderName))
 -> PackageInterface -> Identity PackageInterface)
-> Maybe HeaderName -> PackageInterface -> PackageInterface
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (HeaderName -> Maybe HeaderName
forall a. a -> Maybe a
Just HeaderName
header)