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

module FFICXX.Generate.ContentMaker where

import Control.Lens                           ( (&), (.~), at )
import Control.Monad.Trans.Reader
import Data.Either                            ( rights )
import Data.Functor.Identity                  ( Identity )
import qualified Data.Map as M
import Data.Maybe                             ( mapMaybe  )
import Data.Monoid                            ( (<>) )
import Data.List                              ( intercalate, nub )
import Data.List.Split                        ( splitOn )
import Language.Haskell.Exts.Syntax           ( Module(..)
                                              , Decl(..)
                                              )
import System.FilePath                        ( (<.>), (</>) )
--
import FFICXX.Runtime.CodeGen.Cxx             ( HeaderName(..) )
import qualified FFICXX.Runtime.CodeGen.Cxx as R
--
import FFICXX.Generate.Code.Cpp               ( genAllCppHeaderInclude
                                              , genCppDefMacroAccessor
                                              , genCppDefMacroNonVirtual
                                              , genCppDefMacroTemplateMemberFunction
                                              , genCppDefMacroVirtual
                                              , genCppDefInstAccessor
                                              , genCppDefInstNonVirtual
                                              , genCppDefInstVirtual
                                              , genCppHeaderInstAccessor
                                              , genCppHeaderInstNonVirtual
                                              , genCppHeaderInstVirtual
                                              , genCppHeaderMacroAccessor
                                              , genCppHeaderMacroType
                                              , genCppHeaderMacroVirtual
                                              , genCppHeaderMacroNonVirtual
                                              , 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
                                              , genImportInCast
                                              , genImportInImplementation
                                              , genImportInInterface
                                              , genImportInModule
                                              , genImportInTopLevel
                                              , genTopLevelDef
                                              , hsClassRawType
                                              )
import FFICXX.Generate.Code.HsProxy           ( genProxyInstance )
import FFICXX.Generate.Code.HsTemplate        ( genImportInTemplate
                                              , genImportInTH
                                              , genTemplateMemberFunctions
                                              , genTmplInstance
                                              , genTmplInterface
                                              , genTmplImplementation
                                              )
import FFICXX.Generate.Dependency
import FFICXX.Generate.Name                   ( ffiClassName, hsClassName
                                              , hsFrontNameForTopLevel
                                              )
import FFICXX.Generate.Type.Annotate          ( AnnotateMap )
import FFICXX.Generate.Type.Class             ( Class(..)
                                              , ClassGlobal(..)
                                              , DaughterMap
                                              , ProtectedMethod(..)
                                              , isAbstractClass
                                              )
import FFICXX.Generate.Type.Module            ( ClassImportHeader(..)
                                              , ClassModule(..)
                                              , TemplateClassImportHeader(..)
                                              , TemplateClassModule(..)
                                              , TopLevelImportHeader(..)
                                              )
import FFICXX.Generate.Type.PackageInterface  ( ClassName(..)
                                              , PackageInterface
                                              , PackageName(..)
                                              )
import FFICXX.Generate.Util.HaskellSrcExts


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

csrcDir :: FilePath -> FilePath
csrcDir :: FilePath -> FilePath
csrcDir FilePath
installbasedir = FilePath
installbasedir FilePath -> FilePath -> FilePath
</> FilePath
"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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Class] -> DaughterMap
mkDaughterMap


-- |
buildDaughterDef ::
     ((String,[Class]) -> String)
  -> DaughterMap
  -> String
buildDaughterDef :: ((FilePath, [Class]) -> FilePath) -> DaughterMap -> FilePath
buildDaughterDef (FilePath, [Class]) -> FilePath
f DaughterMap
m =
    let lst :: [(FilePath, [Class])]
lst = DaughterMap -> [(FilePath, [Class])]
forall k a. Map k a -> [(k, a)]
M.toList DaughterMap
m
        f' :: (FilePath, [Class]) -> FilePath
f' (FilePath
x,[Class]
xs) =  (FilePath, [Class]) -> FilePath
f (FilePath
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 (((FilePath, [Class]) -> FilePath)
-> [(FilePath, [Class])] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath, [Class]) -> FilePath
f' [(FilePath, [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 =
    (FilePath -> CMacro Identity) -> [FilePath] -> [CMacro Identity]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x-> CName Identity
-> [CName Identity] -> [CStatement Identity] -> CMacro Identity
forall (f :: * -> *).
CName f -> [CName f] -> [CStatement f] -> CMacro f
R.Define (FilePath -> CName Identity
R.sname (FilePath
"IS_" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Class -> FilePath
class_name Class
c FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"_" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
x FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"_PROTECTED")) [] [FilePath -> CStatement Identity
forall (f :: * -> *). FilePath -> CStatement f
R.CVerbatim FilePath
"()"])
  ([FilePath] -> [CMacro Identity])
-> (Class -> [FilePath]) -> Class -> [CMacro Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtectedMethod -> [FilePath]
unProtected
  (ProtectedMethod -> [FilePath])
-> (Class -> ProtectedMethod) -> Class -> [FilePath]
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] -> FilePath
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 -> FilePath
R.renderBlock (CBlock Identity -> FilePath) -> CBlock Identity -> FilePath
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 ::
     String     -- ^ C prefix
  -> ClassImportHeader
  -> String
buildDeclHeader :: FilePath -> ClassImportHeader -> FilePath
buildDeclHeader FilePath
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 (FilePath -> HeaderName
HdrName (FilePath
cprefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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 ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst((FilePath, FilePath) -> FilePath)
-> (Class -> (FilePath, FilePath)) -> Class -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Class -> (FilePath, FilePath)
hsClassName) Class
aclass FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"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 -> FilePath
R.renderBlock (CBlock Identity -> FilePath) -> CBlock Identity -> FilePath
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 -> FilePath
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 :: FilePath
aliasStr = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                   (Class -> Maybe FilePath) -> [Class] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe FilePath
typedefstmt ([Class] -> [FilePath]) -> [Class] -> [FilePath]
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 FilePath
typedefstmt Class
c = let n1 :: FilePath
n1 = Class -> FilePath
class_name Class
c
                                  n2 :: FilePath
n2 = Class -> FilePath
ffiClassName Class
c
                              in if FilePath
n1 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
n2
                                 then Maybe FilePath
forall a. Maybe a
Nothing
                                 else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
"typedef " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n1 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n2 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
";")

      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 -> FilePath) -> [CMacro Identity] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CMacro Identity -> FilePath
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
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
aliasStr
           , CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n"
           , CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
"#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 ::
     String     -- ^ C prefix
  -> TopLevelImportHeader
  -> String
buildTopLevelHeader :: FilePath -> TopLevelImportHeader -> FilePath
buildTopLevelHeader FilePath
cprefix TopLevelImportHeader
tih =
  let declHeaderStmts :: [CMacro Identity]
declHeaderStmts =
           [ HeaderName -> CMacro Identity
forall (f :: * -> *). HeaderName -> CMacro f
R.Include (FilePath -> HeaderName
HdrName (FilePath
cprefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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 = (TopLevel -> CStatement Identity)
-> [TopLevel] -> [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)
-> (TopLevel -> CFunDecl Identity)
-> TopLevel
-> CStatement Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> CFunDecl Identity
topLevelDecl) ([TopLevel] -> [CStatement Identity])
-> [TopLevel] -> [CStatement Identity]
forall a b. (a -> b) -> a -> b
$ TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih
  in CBlock Identity -> FilePath
R.renderBlock (CBlock Identity -> FilePath) -> CBlock Identity -> FilePath
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 -> FilePath
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 (FilePath -> HeaderName
HdrName (TopLevelImportHeader -> FilePath
tihHeaderFileName TopLevelImportHeader
tih FilePath -> FilePath -> FilePath
<.> FilePath
"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 (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 :: FilePath
aliasStr = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                   (Class -> Maybe FilePath) -> [Class] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Class -> Maybe FilePath
typedefstmt ([Class] -> [FilePath]) -> [Class] -> [FilePath]
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 FilePath
typedefstmt Class
c = let n1 :: FilePath
n1 = Class -> FilePath
class_name Class
c
                                  n2 :: FilePath
n2 = Class -> FilePath
ffiClassName Class
c
                              in if FilePath
n1 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
n2
                                 then Maybe FilePath
forall a. Maybe a
Nothing
                                 else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
"typedef " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n1 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n2 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
";")
      declBodyStr :: FilePath
declBodyStr =
        FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
          (TopLevel -> FilePath) -> [TopLevel] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (CStatement Identity -> FilePath
R.renderCStmt (CStatement Identity -> FilePath)
-> (TopLevel -> CStatement Identity) -> TopLevel -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> CStatement Identity
genTopLevelCppDefinition) (TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih)

  in (CMacro Identity -> FilePath) -> [CMacro Identity] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CMacro Identity -> FilePath
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
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
aliasStr
           , CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
"#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n"
           , CMacro Identity
forall (f :: * -> *). CMacro f
R.EmptyLine
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
"#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
           , FilePath -> CMacro Identity
forall (f :: * -> *). FilePath -> CMacro f
R.Verbatim FilePath
declBodyStr
           ]
       )

-- |
buildFFIHsc :: ClassModule -> Module ()
buildFFIHsc :: ClassModule -> Module ()
buildFFIHsc ClassModule
m = FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (FilePath
mname FilePath -> FilePath -> FilePath
<.> FilePath
"FFI") [[FilePath] -> ModulePragma ()
lang [FilePath
"ForeignFunctionInterface"]] [ImportDecl ()]
ffiImports [Decl ()]
hscBody
  where mname :: FilePath
mname = ClassModule -> FilePath
cmModule ClassModule
m
        ffiImports :: [ImportDecl ()]
ffiImports = [ FilePath -> ImportDecl ()
mkImport FilePath
"Data.Word"
                     , FilePath -> ImportDecl ()
mkImport FilePath
"Data.Int"
                     , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.C"
                     , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                     , FilePath -> ImportDecl ()
mkImport (FilePath
mname FilePath -> FilePath -> FilePath
<.> FilePath
"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 =
    FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"RawType")
      [ [FilePath] -> ModulePragma ()
lang
          [ FilePath
"ForeignFunctionInterface"
          , FilePath
"TypeFamilies"
          , FilePath
"MultiParamTypeClasses"
          , FilePath
"FlexibleInstances"
          , FilePath
"TypeSynonymInstances"
          , FilePath
"EmptyDataDecls"
          , FilePath
"ExistentialQuantification"
          , FilePath
"ScopedTypeVariables"
          ]
      ]
      [ImportDecl ()]
rawtypeImports
      [Decl ()]
rawtypeBody
  where
    rawtypeImports :: [ImportDecl ()]
rawtypeImports = [ FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                     , FilePath -> ImportDecl ()
mkImport FilePath
"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 -> ClassModule -> Module ()
buildInterfaceHs :: AnnotateMap -> ClassModule -> Module ()
buildInterfaceHs AnnotateMap
amap ClassModule
m =
  FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule
    (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Interface")
    [ [FilePath] -> ModulePragma ()
lang
      [ FilePath
"EmptyDataDecls"
      , FilePath
"ExistentialQuantification"
      , FilePath
"FlexibleContexts"
      , FilePath
"FlexibleInstances"
      , FilePath
"ForeignFunctionInterface"
      , FilePath
"MultiParamTypeClasses"
      , FilePath
"ScopedTypeVariables"
      , FilePath
"TypeFamilies"
      , FilePath
"TypeSynonymInstances"
      ]
    ]
    [ImportDecl ()]
ifaceImports
    [Decl ()]
ifaceBody
  where
    classes :: [Class]
classes = [ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m)]
    ifaceImports :: [ImportDecl ()]
ifaceImports = [ FilePath -> ImportDecl ()
mkImport FilePath
"Data.Word"
                   , FilePath -> ImportDecl ()
mkImport FilePath
"Data.Int"
                   , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.C"
                   , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                   , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.Cast"
                   ]
                   [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ClassModule -> [ImportDecl ()]
genImportInInterface 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)
mapM Class -> ReaderT AnnotateMap Identity (Decl ())
genHsFrontDecl [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

-- |
buildCastHs :: ClassModule -> Module ()
buildCastHs :: ClassModule -> Module ()
buildCastHs ClassModule
m = FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Cast")
               [ [FilePath] -> ModulePragma ()
lang [ FilePath
"FlexibleInstances", FilePath
"FlexibleContexts", FilePath
"TypeFamilies"
                      , FilePath
"MultiParamTypeClasses", FilePath
"OverlappingInstances", FilePath
"IncoherentInstances" ] ]
               [ImportDecl ()]
castImports [Decl ()]
body
  where classes :: [Class]
classes = [ ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m) ]
        castImports :: [ImportDecl ()]
castImports =    [ FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                         , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.Cast"
                         , FilePath -> ImportDecl ()
mkImport FilePath
"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 =
    FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Implementation")
      [ [FilePath] -> ModulePragma ()
lang [ FilePath
"EmptyDataDecls"
             , FilePath
"FlexibleContexts"
             , FilePath
"FlexibleInstances"
             , FilePath
"ForeignFunctionInterface"
             , FilePath
"IncoherentInstances"
             , FilePath
"MultiParamTypeClasses"
             , FilePath
"OverlappingInstances"
             , FilePath
"TemplateHaskell"
             , FilePath
"TypeFamilies"
             , FilePath
"TypeSynonymInstances"
             ]
      ]
      [ImportDecl ()]
implImports [Decl ()]
implBody
  where
    classes :: [Class]
classes = [ ClassImportHeader -> Class
cihClass (ClassModule -> ClassImportHeader
cmCIH ClassModule
m) ]
    implImports :: [ImportDecl ()]
implImports = [ FilePath -> ImportDecl ()
mkImport FilePath
"Data.Monoid"                -- for template member
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Data.Word"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Data.Int"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.C"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH"        -- for template member
                  , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH.Syntax" -- for template member
                  , FilePath -> ImportDecl ()
mkImport FilePath
"System.IO.Unsafe"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.Cast"
                  , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.CodeGen.Cxx" -- for template member
                  , FilePath -> ImportDecl ()
mkImport FilePath
"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
yClass -> [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)
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 =
    FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Proxy")
      [ [FilePath] -> ModulePragma ()
lang [ FilePath
"FlexibleInstances"
             , FilePath
"OverloadedStrings"
             , FilePath
"TemplateHaskell"
             ]
      ]
      [ FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
      , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.Cast"
      , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH"
      , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH.Syntax"
      , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.CodeGen.Cxx"
      ]
      [Decl ()]
body
  where
    body :: [Decl ()]
body = [Decl ()]
genProxyInstance



buildTemplateHs :: TemplateClassModule -> Module ()
buildTemplateHs :: TemplateClassModule -> Module ()
buildTemplateHs TemplateClassModule
m =
    FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (TemplateClassModule -> FilePath
tcmModule TemplateClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Template")
      [ [FilePath] -> ModulePragma ()
lang
          [ FilePath
"EmptyDataDecls"
          , FilePath
"FlexibleInstances"
          , FilePath
"MultiParamTypeClasses"
          , FilePath
"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 =    [ FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.C.Types"
                 , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
                 , FilePath -> ImportDecl ()
mkImport FilePath
"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 =
  FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (TemplateClassModule -> FilePath
tcmModule TemplateClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"TH")
    [ [FilePath] -> ModulePragma ()
lang  [FilePath
"TemplateHaskell"] ]
    (   [ FilePath -> ImportDecl ()
mkImport FilePath
"Data.Char"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Data.List"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Data.Monoid"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.C.Types"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Foreign.Ptr"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH"
        , FilePath -> ImportDecl ()
mkImport FilePath
"Language.Haskell.TH.Syntax"
        , FilePath -> ImportDecl ()
mkImport FilePath
"FFICXX.Runtime.CodeGen.Cxx"
        , FilePath -> ImportDecl ()
mkImport FilePath
"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 =    [ FilePath -> ImportDecl ()
mkImport (TemplateClassModule -> FilePath
tcmModule TemplateClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"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)

-- |
buildInterfaceHSBOOT :: String -> Module ()
buildInterfaceHSBOOT :: FilePath -> Module ()
buildInterfaceHSBOOT FilePath
mname = FilePath
-> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()
mkModule (FilePath
mname FilePath -> FilePath -> FilePath
<.> FilePath
"Interface") [] [] [Decl ()]
hsbootBody
  where cname :: FilePath
cname = [FilePath] -> FilePath
forall a. [a] -> a
last (FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"." FilePath
mname)
        hsbootBody :: [Decl ()]
hsbootBody = [ Context ()
-> FilePath -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()
mkClass Context ()
cxEmpty (Char
'I'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cname) [FilePath -> TyVarBind ()
mkTBind FilePath
"a"] [] ]

-- |
buildModuleHs :: ClassModule -> Module ()
buildModuleHs :: ClassModule -> Module ()
buildModuleHs ClassModule
m = FilePath
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE (ClassModule -> FilePath
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]) -> TopLevelImportHeader -> Module ()
buildTopLevelHs :: FilePath
-> ([ClassModule], [TemplateClassModule])
-> TopLevelImportHeader
-> Module ()
buildTopLevelHs FilePath
modname ([ClassModule]
mods,[TemplateClassModule]
tmods) TopLevelImportHeader
tih =
    FilePath
-> [ModulePragma ()]
-> [ExportSpec ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
mkModuleE FilePath
modname [ModulePragma ()]
pkgExtensions [ExportSpec ()]
pkgExports [ImportDecl ()]
pkgImports [Decl ()]
pkgBody
  where
    tfns :: [TopLevel]
tfns = TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih
    pkgExtensions :: [ModulePragma ()]
pkgExtensions = [ [FilePath] -> ModulePragma ()
lang [ FilePath
"FlexibleContexts", FilePath
"FlexibleInstances" ] ]
    pkgExports :: [ExportSpec ()]
pkgExports =     (ClassModule -> ExportSpec ()) -> [ClassModule] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ExportSpec ()
emodule (FilePath -> ExportSpec ())
-> (ClassModule -> FilePath) -> ClassModule -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> FilePath
cmModule) [ClassModule]
mods
                 [ExportSpec ()] -> [ExportSpec ()] -> [ExportSpec ()]
forall a. [a] -> [a] -> [a]
++  (TopLevel -> ExportSpec ()) -> [TopLevel] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar (QName () -> ExportSpec ())
-> (TopLevel -> QName ()) -> TopLevel -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> QName ()
unqual (FilePath -> QName ())
-> (TopLevel -> FilePath) -> TopLevel -> QName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> FilePath
hsFrontNameForTopLevel) [TopLevel]
tfns

    pkgImports :: [ImportDecl ()]
pkgImports = FilePath
-> ([ClassModule], [TemplateClassModule])
-> TopLevelImportHeader
-> [ImportDecl ()]
genImportInTopLevel FilePath
modname ([ClassModule]
mods,[TemplateClassModule]
tmods) TopLevelImportHeader
tih

    pkgBody :: [Decl ()]
pkgBody    =    (TopLevel -> Decl ()) -> [TopLevel] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (TopLevelImportHeader -> TopLevel -> Decl ()
genTopLevelFFI TopLevelImportHeader
tih) [TopLevel]
tfns
                 [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ (TopLevel -> [Decl ()]) -> [TopLevel] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopLevel -> [Decl ()]
genTopLevelDef [TopLevel]
tfns

-- |
buildPackageInterface :: PackageInterface
                      -> PackageName
                      -> [ClassImportHeader]
                      -> PackageInterface
buildPackageInterface :: PackageInterface
-> PackageName -> [ClassImportHeader] -> PackageInterface
buildPackageInterface PackageInterface
pinfc PackageName
pkgname = (ClassImportHeader -> PackageInterface -> PackageInterface)
-> PackageInterface -> [ClassImportHeader] -> PackageInterface
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 :: FilePath
name = (Class -> FilePath
class_name (Class -> FilePath)
-> (ClassImportHeader -> Class) -> ClassImportHeader -> FilePath
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,FilePath -> ClassName
ClsName FilePath
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)