{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module FFICXX.Generate.Code.HsFrontEnd where

import Control.Monad.Reader
import Data.Either                             (lefts,rights)
import Data.List
import Data.Monoid                             ((<>))
import Language.Haskell.Exts.Build             (app,letE,name,pApp)
import Language.Haskell.Exts.Syntax            (Decl(..),ExportSpec(..),ImportDecl(..))
import System.FilePath                         ((<.>))
--
import FFICXX.Generate.Code.Primitive          (CFunSig(..),HsFunSig(..)
                                               ,accessorSignature
                                               ,classConstraints
                                               ,convertCpp2HS
                                               ,extractArgRetTypes
                                               ,functionSignature
                                               ,hsFuncXformer
                                               )
import FFICXX.Generate.Name                    (accessorName
                                               ,aliasedFuncName
                                               ,hsClassName
                                               ,hscAccessorName
                                               ,hscFuncName
                                               ,hsFuncName
                                               ,hsFrontNameForTopLevel
                                               ,typeclassName
                                               )
import FFICXX.Generate.Dependency              (class_allparents
                                               ,extractClassDepForTopLevel
                                               ,getClassModuleBase,getTClassModuleBase
                                               ,argumentDependency,returnDependency
                                               )
import FFICXX.Generate.Type.Class
import FFICXX.Generate.Type.Annotate
import FFICXX.Generate.Type.Module
import FFICXX.Generate.Util
import FFICXX.Generate.Util.HaskellSrcExts


genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl Class
c = do
  -- TODO: revive annotation
  -- for the time being, let's ignore annotation.
  -- amap <- ask
  -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap
  let cdecl :: Decl ()
cdecl = Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()
mkClass (Class -> Context ()
classConstraints Class
c) (Class -> String
typeclassName Class
c) [String -> TyVarBind ()
mkTBind String
"a"] [ClassDecl ()]
body
      sigdecl :: Function -> Decl ()
sigdecl Function
f = String -> Type () -> Decl ()
mkFunSig (Class -> Function -> String
hsFuncName Class
c Function
f) (Class -> Function -> Type ()
functionSignature Class
c Function
f)
      body :: [ClassDecl ()]
body = (Function -> ClassDecl ()) -> [Function] -> [ClassDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (Decl () -> ClassDecl ()
clsDecl (Decl () -> ClassDecl ())
-> (Function -> Decl ()) -> Function -> ClassDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Decl ()
sigdecl) ([Function] -> [ClassDecl ()])
-> (Class -> [Function]) -> Class -> [ClassDecl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Function] -> [Function]
virtualFuncs ([Function] -> [Function])
-> (Class -> [Function]) -> Class -> [Function]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Function]
class_funcs (Class -> [ClassDecl ()]) -> Class -> [ClassDecl ()]
forall a b. (a -> b) -> a -> b
$ Class
c
  Decl () -> Reader AnnotateMap (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
cdecl

-------------------

genHsFrontInst :: Class -> Class -> [Decl ()]
genHsFrontInst :: Class -> Class -> [Decl ()]
genHsFrontInst Class
parent Class
child
  | (Bool -> Bool
not(Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Class -> Bool
isAbstractClass) Class
child =
    let idecl :: Decl ()
idecl = Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
cxEmpty (Class -> String
typeclassName Class
parent) [Maybe Class -> Types -> Type ()
convertCpp2HS (Class -> Maybe Class
forall a. a -> Maybe a
Just Class
child) Types
SelfType] [InstDecl ()]
body
        defn :: Function -> Decl ()
defn Function
f = String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 (Class -> Function -> String
hsFuncName Class
child Function
f) [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing
          where rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar (Function -> String
hsFuncXformer Function
f)) (String -> Exp ()
mkVar (Class -> Function -> String
hscFuncName Class
child Function
f))
        body :: [InstDecl ()]
body = (Function -> InstDecl ()) -> [Function] -> [InstDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (Decl () -> InstDecl ()
insDecl (Decl () -> InstDecl ())
-> (Function -> Decl ()) -> Function -> InstDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Decl ()
defn) ([Function] -> [InstDecl ()])
-> (Class -> [Function]) -> Class -> [InstDecl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Function] -> [Function]
virtualFuncs ([Function] -> [Function])
-> (Class -> [Function]) -> Class -> [Function]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Function]
class_funcs (Class -> [InstDecl ()]) -> Class -> [InstDecl ()]
forall a b. (a -> b) -> a -> b
$ Class
parent
    in [Decl ()
idecl]
  | Bool
otherwise = []




---------------------

genHsFrontInstNew :: Class         -- ^ only concrete class
                  -> Reader AnnotateMap [Decl ()]
genHsFrontInstNew :: Class -> Reader AnnotateMap [Decl ()]
genHsFrontInstNew Class
c = do
  -- amap <- ask
  let fs :: [Function]
fs = (Function -> Bool) -> [Function] -> [Function]
forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isNewFunc (Class -> [Function]
class_funcs Class
c)
  [Decl ()] -> Reader AnnotateMap [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl ()] -> Reader AnnotateMap [Decl ()])
-> ((Function -> [Decl ()]) -> [Decl ()])
-> (Function -> [Decl ()])
-> Reader AnnotateMap [Decl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Function -> [Decl ()]) -> [Function] -> [Decl ()])
-> [Function] -> (Function -> [Decl ()]) -> [Decl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Function -> [Decl ()]) -> [Function] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Function]
fs ((Function -> [Decl ()]) -> Reader AnnotateMap [Decl ()])
-> (Function -> [Decl ()]) -> Reader AnnotateMap [Decl ()]
forall a b. (a -> b) -> a -> b
$ \Function
f ->
    let
        -- for the time being, let's ignore annotation.
        -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap
        -- newfuncann = mkComment 0 cann
        rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar (Function -> String
hsFuncXformer Function
f)) (String -> Exp ()
mkVar (Class -> Function -> String
hscFuncName Class
c Function
f))
    in String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (Class -> Function -> String
aliasedFuncName Class
c Function
f) (Class -> Function -> Type ()
functionSignature Class
c Function
f) [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing

genHsFrontInstNonVirtual :: Class -> [Decl ()]
genHsFrontInstNonVirtual :: Class -> [Decl ()]
genHsFrontInstNonVirtual Class
c =
  ((Function -> [Decl ()]) -> [Function] -> [Decl ()])
-> [Function] -> (Function -> [Decl ()]) -> [Decl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Function -> [Decl ()]) -> [Function] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Function]
nonvirtualFuncs ((Function -> [Decl ()]) -> [Decl ()])
-> (Function -> [Decl ()]) -> [Decl ()]
forall a b. (a -> b) -> a -> b
$ \Function
f ->
    let rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar (Function -> String
hsFuncXformer Function
f)) (String -> Exp ()
mkVar (Class -> Function -> String
hscFuncName Class
c Function
f))
    in String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (Class -> Function -> String
aliasedFuncName Class
c Function
f) (Class -> Function -> Type ()
functionSignature Class
c Function
f) [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing
 where nonvirtualFuncs :: [Function]
nonvirtualFuncs = [Function] -> [Function]
nonVirtualNotNewFuncs (Class -> [Function]
class_funcs Class
c)

-----

genHsFrontInstStatic :: Class -> [Decl ()]
genHsFrontInstStatic :: Class -> [Decl ()]
genHsFrontInstStatic Class
c =
  ((Function -> [Decl ()]) -> [Function] -> [Decl ()])
-> [Function] -> (Function -> [Decl ()]) -> [Decl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Function -> [Decl ()]) -> [Function] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Function] -> [Function]
staticFuncs (Class -> [Function]
class_funcs Class
c)) ((Function -> [Decl ()]) -> [Decl ()])
-> (Function -> [Decl ()]) -> [Decl ()]
forall a b. (a -> b) -> a -> b
$ \Function
f ->
    let rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar (Function -> String
hsFuncXformer Function
f)) (String -> Exp ()
mkVar (Class -> Function -> String
hscFuncName Class
c Function
f))
    in String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (Class -> Function -> String
aliasedFuncName Class
c Function
f) (Class -> Function -> Type ()
functionSignature Class
c Function
f) [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing

-----

genHsFrontInstVariables :: Class -> [Decl ()]
genHsFrontInstVariables :: Class -> [Decl ()]
genHsFrontInstVariables Class
c =
  ((Variable -> [Decl ()]) -> [Variable] -> [Decl ()])
-> [Variable] -> (Variable -> [Decl ()]) -> [Decl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Variable -> [Decl ()]) -> [Variable] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Class -> [Variable]
class_vars Class
c) ((Variable -> [Decl ()]) -> [Decl ()])
-> (Variable -> [Decl ()]) -> [Decl ()]
forall a b. (a -> b) -> a -> b
$ \Variable
v ->
    let rhs :: Accessor -> Exp ()
rhs Accessor
accessor =
          Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar (case Accessor
accessor of Accessor
Getter -> String
"xform0"; Accessor
_ -> String
"xform1"))
              (String -> Exp ()
mkVar (Class -> Variable -> Accessor -> String
hscAccessorName Class
c Variable
v Accessor
accessor))
    in    String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (Class -> Variable -> Accessor -> String
accessorName Class
c Variable
v Accessor
Getter) (Class -> Variable -> Accessor -> Type ()
accessorSignature Class
c Variable
v Accessor
Getter) [] (Accessor -> Exp ()
rhs Accessor
Getter) Maybe (Binds ())
forall a. Maybe a
Nothing
       [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (Class -> Variable -> Accessor -> String
accessorName Class
c Variable
v Accessor
Setter) (Class -> Variable -> Accessor -> Type ()
accessorSignature Class
c Variable
v Accessor
Setter) [] (Accessor -> Exp ()
rhs Accessor
Setter) Maybe (Binds ())
forall a. Maybe a
Nothing




--------------------------

hsClassRawType :: Class -> [Decl ()]
hsClassRawType :: Class -> [Decl ()]
hsClassRawType Class
c =
  [ String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkData    String
rawname [] [] Maybe (Deriving ())
forall a. Maybe a
Nothing
  , String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkNewtype String
highname [] [Maybe [TyVarBind ()]
-> Maybe (Context ()) -> ConDecl () -> QualConDecl ()
qualConDecl Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (String -> [Type ()] -> ConDecl ()
conDecl String
highname [Type () -> Type () -> Type ()
tyapp Type ()
tyPtr Type ()
rawtype])] Maybe (Deriving ())
mderiv
  , Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
cxEmpty String
"FPtr" [Type ()
hightype]
      [ Type () -> Type () -> InstDecl ()
insType (Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"Raw") Type ()
hightype) Type ()
rawtype
      , Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"get_fptr" [Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
highname) [String -> Pat ()
mkPVar String
"ptr"]] (String -> Exp ()
mkVar String
"ptr") Maybe (Binds ())
forall a. Maybe a
Nothing)
      , Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"cast_fptr_to_obj" [] (String -> Exp ()
con String
highname) Maybe (Binds ())
forall a. Maybe a
Nothing)
      ]

  ]
 where (String
highname,String
rawname) = Class -> (String, String)
hsClassName Class
c
       hightype :: Type ()
hightype = String -> Type ()
tycon String
highname
       rawtype :: Type ()
rawtype = String -> Type ()
tycon String
rawname
       mderiv :: Maybe (Deriving ())
mderiv = Deriving () -> Maybe (Deriving ())
forall a. a -> Maybe a
Just ([InstRule ()] -> Deriving ()
mkDeriving [InstRule ()
i_eq,InstRule ()
i_ord,InstRule ()
i_show])
         where i_eq :: InstRule ()
i_eq   = Maybe [TyVarBind ()]
-> Maybe (Context ()) -> InstHead () -> InstRule ()
irule Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (QName () -> InstHead ()
ihcon (String -> QName ()
unqual String
"Eq"))
               i_ord :: InstRule ()
i_ord  = Maybe [TyVarBind ()]
-> Maybe (Context ()) -> InstHead () -> InstRule ()
irule Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (QName () -> InstHead ()
ihcon (String -> QName ()
unqual String
"Ord"))
               i_show :: InstRule ()
i_show = Maybe [TyVarBind ()]
-> Maybe (Context ()) -> InstHead () -> InstRule ()
irule Maybe [TyVarBind ()]
forall a. Maybe a
Nothing Maybe (Context ())
forall a. Maybe a
Nothing (QName () -> InstHead ()
ihcon (String -> QName ()
unqual String
"Show"))


------------
-- upcast --
------------

genHsFrontUpcastClass :: Class -> [Decl ()]
genHsFrontUpcastClass :: Class -> [Decl ()]
genHsFrontUpcastClass Class
c = String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (String
"upcast"String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
highname) Type ()
typ [String -> Pat ()
mkPVar String
"h"] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing
  where (String
highname,String
rawname) = Class -> (String, String)
hsClassName Class
c
        hightype :: Type ()
hightype = String -> Type ()
tycon String
highname
        rawtype :: Type ()
rawtype = String -> Type ()
tycon String
rawname
        iname :: String
iname = Class -> String
typeclassName Class
c
        a_bind :: TyVarBind ()
a_bind = Name () -> TyVarBind ()
unkindedVar (String -> Name ()
name String
"a")
        a_tvar :: Type ()
a_tvar = String -> Type ()
mkTVar String
"a"
        typ :: Type ()
typ = Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
tyForall ([TyVarBind ()] -> Maybe [TyVarBind ()]
forall a. a -> Maybe a
Just [TyVarBind ()
a_bind])
                (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just ([Asst ()] -> Context ()
cxTuple [QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
"FPtr") [Type ()
a_tvar], QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
iname) [Type ()
a_tvar]]))
                (Type () -> Type () -> Type ()
tyfun Type ()
a_tvar Type ()
hightype)
        rhs :: Exp ()
rhs = [Decl ()] -> Exp () -> Exp ()
letE [ Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()
pbind (String -> Pat ()
mkPVar String
"fh") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"get_fptr") (String -> Exp ()
mkVar String
"h")) Maybe (Binds ())
forall a. Maybe a
Nothing
                   , Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()
pbind (String -> Type () -> Pat ()
mkPVarSig String
"fh2" (Type () -> Type () -> Type ()
tyapp Type ()
tyPtr Type ()
rawtype))
                       (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"castPtr") (String -> Exp ()
mkVar String
"fh")) Maybe (Binds ())
forall a. Maybe a
Nothing
                   ]
                   (String -> Exp ()
mkVar String
"cast_fptr_to_obj" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
mkVar String
"fh2")


--------------
-- downcast --
--------------

genHsFrontDowncastClass :: Class -> [Decl ()]
genHsFrontDowncastClass :: Class -> [Decl ()]
genHsFrontDowncastClass Class
c = String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun (String
"downcast"String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
highname) Type ()
typ [String -> Pat ()
mkPVar String
"h"] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing
  where (String
highname,String
_rawname) = Class -> (String, String)
hsClassName Class
c
        hightype :: Type ()
hightype = String -> Type ()
tycon String
highname
        iname :: String
iname = Class -> String
typeclassName Class
c
        a_bind :: TyVarBind ()
a_bind = Name () -> TyVarBind ()
unkindedVar (String -> Name ()
name String
"a")
        a_tvar :: Type ()
a_tvar = String -> Type ()
mkTVar String
"a"
        typ :: Type ()
typ = Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
tyForall ([TyVarBind ()] -> Maybe [TyVarBind ()]
forall a. a -> Maybe a
Just [TyVarBind ()
a_bind])
                (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just ([Asst ()] -> Context ()
cxTuple [QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
"FPtr") [Type ()
a_tvar], QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
iname) [Type ()
a_tvar]]))
                (Type () -> Type () -> Type ()
tyfun Type ()
hightype Type ()
a_tvar)
        rhs :: Exp ()
rhs = [Decl ()] -> Exp () -> Exp ()
letE [ Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()
pbind (String -> Pat ()
mkPVar String
"fh") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"get_fptr") (String -> Exp ()
mkVar String
"h")) Maybe (Binds ())
forall a. Maybe a
Nothing
                   , Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()
pbind (String -> Pat ()
mkPVar String
"fh2") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"castPtr") (String -> Exp ()
mkVar String
"fh")) Maybe (Binds ())
forall a. Maybe a
Nothing
                   ]
                   (String -> Exp ()
mkVar String
"cast_fptr_to_obj" Exp () -> Exp () -> Exp ()
`app` String -> Exp ()
mkVar String
"fh2")


------------------------
-- Top Level Function --
------------------------


genTopLevelDef :: TopLevel -> [Decl ()]
genTopLevelDef :: TopLevel -> [Decl ()]
genTopLevelDef f :: TopLevel
f@TopLevelFunction {String
[Arg]
Maybe String
Types
toplevelfunc_alias :: TopLevel -> Maybe String
toplevelfunc_args :: TopLevel -> [Arg]
toplevelfunc_name :: TopLevel -> String
toplevelfunc_ret :: TopLevel -> Types
toplevelfunc_alias :: Maybe String
toplevelfunc_args :: [Arg]
toplevelfunc_name :: String
toplevelfunc_ret :: Types
..} =
    let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel TopLevel
f
        HsFunSig [Type ()]
typs [Asst ()]
assts =
          Maybe Class -> Bool -> CFunSig -> HsFunSig
extractArgRetTypes
            Maybe Class
forall a. Maybe a
Nothing
            Bool
False
            ([Arg] -> Types -> CFunSig
CFunSig [Arg]
toplevelfunc_args Types
toplevelfunc_ret)
        sig :: Type ()
sig = Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type () -> Type ()
tyForall Maybe [TyVarBind ()]
forall a. Maybe a
Nothing (Context () -> Maybe (Context ())
forall a. a -> Maybe a
Just ([Asst ()] -> Context ()
cxTuple [Asst ()]
assts)) ((Type () -> Type () -> Type ()) -> [Type ()] -> Type ()
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type () -> Type () -> Type ()
tyfun [Type ()]
typs)
        xformerstr :: String
xformerstr = let len :: Int
len = [Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
toplevelfunc_args in if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then String
"xform" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) else String
"xformnull"
        cfname :: String
cfname = String
"c_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers String
fname
        rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
xformerstr) (String -> Exp ()
mkVar String
cfname)

    in String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun String
fname Type ()
sig [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing
genTopLevelDef v :: TopLevel
v@TopLevelVariable {String
Maybe String
Types
toplevelvar_alias :: TopLevel -> Maybe String
toplevelvar_name :: TopLevel -> String
toplevelvar_ret :: TopLevel -> Types
toplevelvar_alias :: Maybe String
toplevelvar_name :: String
toplevelvar_ret :: Types
..} =
    let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel TopLevel
v
        cfname :: String
cfname = String
"c_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers String
fname
        rtyp :: Type ()
rtyp = Maybe Class -> Types -> Type ()
convertCpp2HS Maybe Class
forall a. Maybe a
Nothing Types
toplevelvar_ret
        sig :: Type ()
sig = Type () -> Type () -> Type ()
tyapp (String -> Type ()
tycon String
"IO") Type ()
rtyp
        rhs :: Exp ()
rhs = Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"xformnull") (String -> Exp ()
mkVar String
cfname)

    in String
-> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]
mkFun String
fname Type ()
sig [] Exp ()
rhs Maybe (Binds ())
forall a. Maybe a
Nothing


------------
-- Export --
------------

genExport :: Class -> [ExportSpec ()]
genExport :: Class -> [ExportSpec ()]
genExport Class
c =
    let espec :: String -> ExportSpec ()
espec String
n = if [Function] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Function] -> Bool)
-> ([Function] -> [Function]) -> [Function] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Function -> Bool) -> [Function] -> [Function]
forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isVirtualFunc) ([Function] -> Bool) -> [Function] -> Bool
forall a b. (a -> b) -> a -> b
$ (Class -> [Function]
class_funcs Class
c)
                    then Namespace () -> QName () -> ExportSpec ()
eabs Namespace ()
nonamespace (String -> QName ()
unqual String
n)
                    else QName () -> ExportSpec ()
ethingall (String -> QName ()
unqual String
n)
    in if Class -> Bool
isAbstractClass Class
c
       then [ String -> ExportSpec ()
espec (Class -> String
typeclassName Class
c) ]
       else [ QName () -> ExportSpec ()
ethingall (String -> QName ()
unqual (((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
c))
            , String -> ExportSpec ()
espec (Class -> String
typeclassName Class
c)
            , QName () -> ExportSpec ()
evar (String -> QName ()
unqual (String
"upcast" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ((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
c))
            , QName () -> ExportSpec ()
evar (String -> QName ()
unqual (String
"downcast" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ((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
c)) ]
            [ExportSpec ()] -> [ExportSpec ()] -> [ExportSpec ()]
forall a. Semigroup a => a -> a -> a
<> Class -> [ExportSpec ()]
genExportConstructorAndNonvirtual Class
c
            [ExportSpec ()] -> [ExportSpec ()] -> [ExportSpec ()]
forall a. Semigroup a => a -> a -> a
<> Class -> [ExportSpec ()]
genExportStatic Class
c

-- | constructor and non-virtual function
genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]
genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]
genExportConstructorAndNonvirtual Class
c = (String -> ExportSpec ()) -> [String] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar (QName () -> ExportSpec ())
-> (String -> QName ()) -> String -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual) [String]
fns
  where fs :: [Function]
fs = Class -> [Function]
class_funcs Class
c
        fns :: [String]
fns = (Function -> String) -> [Function] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Function -> String
aliasedFuncName Class
c) ([Function] -> [Function]
constructorFuncs [Function]
fs
                                       [Function] -> [Function] -> [Function]
forall a. Semigroup a => a -> a -> a
<> [Function] -> [Function]
nonVirtualNotNewFuncs [Function]
fs)

-- | staic function export list
genExportStatic :: Class -> [ExportSpec ()]
genExportStatic :: Class -> [ExportSpec ()]
genExportStatic Class
c = (String -> ExportSpec ()) -> [String] -> [ExportSpec ()]
forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar (QName () -> ExportSpec ())
-> (String -> QName ()) -> String -> ExportSpec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName ()
unqual) [String]
fns
  where fs :: [Function]
fs = Class -> [Function]
class_funcs Class
c
        fns :: [String]
fns = (Function -> String) -> [Function] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Function -> String
aliasedFuncName Class
c) ([Function] -> [Function]
staticFuncs [Function]
fs)


------------
-- Import --
------------

genExtraImport :: ClassModule -> [ImportDecl ()]
genExtraImport :: ClassModule -> [ImportDecl ()]
genExtraImport ClassModule
cm = (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> ImportDecl ()
mkImport (ClassModule -> [String]
cmExtraImport ClassModule
cm)


genImportInModule :: Class -> [ImportDecl ()]
genImportInModule :: Class -> [ImportDecl ()]
genImportInModule Class
x = (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
xString -> String -> String
<.>String
y)) [String
"RawType",String
"Interface",String
"Implementation"]


genImportInInterface :: ClassModule -> [ImportDecl ()]
genImportInInterface :: ClassModule -> [ImportDecl ()]
genImportInInterface ClassModule
m =
  let modlstraw :: [Either TemplateClass Class]
modlstraw = ClassModule -> [Either TemplateClass Class]
cmImportedModulesRaw ClassModule
m
      modlstparent :: [Either TemplateClass Class]
modlstparent = ClassModule -> [Either TemplateClass Class]
cmImportedModulesHighNonSource ClassModule
m
      modlsthigh :: [Either TemplateClass Class]
modlsthigh = ClassModule -> [Either TemplateClass Class]
cmImportedModulesHighSource ClassModule
m
  in  [String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"RawType")]
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ((Either TemplateClass Class -> ImportDecl ())
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> ImportDecl ())
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> ImportDecl ())
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map [Either TemplateClass Class]
modlstraw
           (\case
               Left TemplateClass
t -> String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")
               Right Class
c -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.>String
"RawType")
           )
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ((Either TemplateClass Class -> ImportDecl ())
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> ImportDecl ())
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> ImportDecl ())
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map [Either TemplateClass Class]
modlstparent
           (\case
               Left TemplateClass
t -> String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")
               Right Class
c -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
c String -> String -> String
<.>String
"Interface")
           )
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> ((Either TemplateClass Class -> ImportDecl ())
 -> [Either TemplateClass Class] -> [ImportDecl ()])
-> [Either TemplateClass Class]
-> (Either TemplateClass Class -> ImportDecl ())
-> [ImportDecl ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either TemplateClass Class -> ImportDecl ())
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map [Either TemplateClass Class]
modlsthigh
           (\case
               Left TemplateClass
t  -> -- TODO: *.Template in the same package needs to have hs-boot.
                          --       Currently, we do not have it yet.
                          String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")
               Right Class
c -> String -> ImportDecl ()
mkImportSrc (Class -> String
getClassModuleBase Class
cString -> String -> String
<.>String
"Interface")
           )

-- |
genImportInCast :: ClassModule -> [ImportDecl ()]
genImportInCast :: ClassModule -> [ImportDecl ()]
genImportInCast ClassModule
m = [ String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"RawType")
                   ,  String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Interface") ]

-- |
genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation ClassModule
m =
  let modlstraw' :: [Either TemplateClass Class]
modlstraw' = ClassModule -> [Either TemplateClass Class]
cmImportedModulesForFFI ClassModule
m
      modlsthigh :: [Either TemplateClass Class]
modlsthigh = [Either TemplateClass Class] -> [Either TemplateClass Class]
forall a. Eq a => [a] -> [a]
nub ([Either TemplateClass Class] -> [Either TemplateClass Class])
-> [Either TemplateClass Class] -> [Either TemplateClass Class]
forall a b. (a -> b) -> a -> b
$ (Class -> Either TemplateClass Class)
-> [Class] -> [Either TemplateClass Class]
forall a b. (a -> b) -> [a] -> [b]
map Class -> Either TemplateClass Class
forall a b. b -> Either a b
Right ([Class] -> [Either TemplateClass Class])
-> [Class] -> [Either TemplateClass Class]
forall a b. (a -> b) -> a -> b
$ Class -> [Class]
class_allparents (Class -> [Class]) -> Class -> [Class]
forall a b. (a -> b) -> a -> b
$ ClassImportHeader -> Class
cihClass (ClassImportHeader -> Class) -> ClassImportHeader -> Class
forall a b. (a -> b) -> a -> b
$ ClassModule -> ClassImportHeader
cmCIH ClassModule
m
      modlstraw :: [Either TemplateClass Class]
modlstraw = (Either TemplateClass Class -> Bool)
-> [Either TemplateClass Class] -> [Either TemplateClass Class]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> (Either TemplateClass Class -> Bool)
-> Either TemplateClass Class
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Either TemplateClass Class
 -> [Either TemplateClass Class] -> Bool)
-> [Either TemplateClass Class]
-> Either TemplateClass Class
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either TemplateClass Class -> [Either TemplateClass Class] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Either TemplateClass Class]
modlsthigh)) [Either TemplateClass Class]
modlstraw'
  in  [ String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"RawType")
      , String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"FFI")
      , String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Interface")
      , String -> ImportDecl ()
mkImport (ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Cast") ]
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> (Either TemplateClass Class -> [ImportDecl ()])
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\case Left TemplateClass
t -> [String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")]; Right Class
c -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
cString -> String -> String
<.>String
y)) [String
"RawType",String
"Cast",String
"Interface"]) [Either TemplateClass Class]
modlstraw
      [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> (Either TemplateClass Class -> [ImportDecl ()])
-> [Either TemplateClass Class] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\case Left TemplateClass
t -> [String -> ImportDecl ()
mkImport (TemplateClass -> String
getTClassModuleBase TemplateClass
t String -> String -> String
<.> String
"Template")]; Right Class
c -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (Class -> String
getClassModuleBase Class
cString -> String -> String
<.>String
y)) [String
"RawType",String
"Cast",String
"Interface"]) [Either TemplateClass Class]
modlsthigh


-- | generate import list for a given top-level function
--   currently this may generate duplicate import list.
-- TODO: eliminate duplicated imports.
genImportForTopLevel :: TopLevel -> [ImportDecl ()]
genImportForTopLevel :: TopLevel -> [ImportDecl ()]
genImportForTopLevel TopLevel
f =
  let dep4func :: Dep4Func
dep4func = TopLevel -> Dep4Func
extractClassDepForTopLevel TopLevel
f
      ecs :: [Either TemplateClass Class]
ecs = Dep4Func -> [Either TemplateClass Class]
returnDependency Dep4Func
dep4func [Either TemplateClass Class]
-> [Either TemplateClass Class] -> [Either TemplateClass Class]
forall a. [a] -> [a] -> [a]
++ Dep4Func -> [Either TemplateClass Class]
argumentDependency Dep4Func
dep4func
      cmods :: [String]
cmods = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Class -> String) -> [Class] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Class -> String
getClassModuleBase ([Class] -> [String]) -> [Class] -> [String]
forall a b. (a -> b) -> a -> b
$ [Either TemplateClass Class] -> [Class]
forall a b. [Either a b] -> [b]
rights [Either TemplateClass Class]
ecs
      tmods :: [String]
tmods = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (TemplateClass -> String) -> [TemplateClass] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TemplateClass -> String
getTClassModuleBase ([TemplateClass] -> [String]) -> [TemplateClass] -> [String]
forall a b. (a -> b) -> a -> b
$ [Either TemplateClass Class] -> [TemplateClass]
forall a b. [Either a b] -> [a]
lefts [Either TemplateClass Class]
ecs
  in    (String -> [ImportDecl ()]) -> [String] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (String
xString -> String -> String
<.>String
y)) [String
"RawType",String
"Cast",String
"Interface"]) [String]
cmods
     [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. Semigroup a => a -> a -> a
<> (String -> [ImportDecl ()]) -> [String] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\String
y -> String -> ImportDecl ()
mkImport (String
xString -> String -> String
<.>String
y)) [String
"Template"]) [String]
tmods

-- | generate import list for top level module
genImportInTopLevel ::
     String
  -> ([ClassModule],[TemplateClassModule])
  -> TopLevelImportHeader
  -> [ImportDecl ()]
genImportInTopLevel :: String
-> ([ClassModule], [TemplateClassModule])
-> TopLevelImportHeader
-> [ImportDecl ()]
genImportInTopLevel String
modname ([ClassModule]
mods,[TemplateClassModule]
tmods) TopLevelImportHeader
tih =
  let tfns :: [TopLevel]
tfns = TopLevelImportHeader -> [TopLevel]
tihFuncs TopLevelImportHeader
tih
  in    (ClassModule -> ImportDecl ()) -> [ClassModule] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ImportDecl ()
mkImport (String -> ImportDecl ())
-> (ClassModule -> String) -> ClassModule -> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> String
cmModule) [ClassModule]
mods
     [ImportDecl ()] -> [ImportDecl ()] -> [ImportDecl ()]
forall a. [a] -> [a] -> [a]
++ if [TopLevel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TopLevel]
tfns
        then []
        else    (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]
++ (ClassImportHeader -> ImportDecl ())
-> [ClassImportHeader] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\ClassImportHeader
c -> String -> ImportDecl ()
mkImport (String
modname String -> String -> String
<.> ((String, String) -> String
forall a b. (a, b) -> a
fst((String, String) -> String)
-> (ClassImportHeader -> (String, String))
-> ClassImportHeader
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Class -> (String, String)
hsClassName(Class -> (String, String))
-> (ClassImportHeader -> Class)
-> ClassImportHeader
-> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ClassImportHeader -> Class
cihClass) ClassImportHeader
c String -> String -> String
<.> String
"RawType")) (TopLevelImportHeader -> [ClassImportHeader]
tihClassDep TopLevelImportHeader
tih)
             [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]
++ (TopLevel -> [ImportDecl ()]) -> [TopLevel] -> [ImportDecl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopLevel -> [ImportDecl ()]
genImportForTopLevel [TopLevel]
tfns