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

module FFICXX.Generate.Code.HsFrontEnd where

import Control.Monad.Reader (Reader)
import Data.Either (lefts, rights)
import qualified Data.List as L
import FFICXX.Generate.Code.Primitive
  ( CFunSig (..),
    HsFunSig (..),
    accessorSignature,
    classConstraints,
    convertCpp2HS,
    extractArgRetTypes,
    functionSignature,
    hsFuncXformer,
  )
import FFICXX.Generate.Dependency
  ( argumentDependency,
    extractClassDepForTLOrdinary,
    extractClassDepForTLTemplate,
    returnDependency,
  )
import FFICXX.Generate.Dependency.Graph
  ( getCyclicDepSubmodules,
    locateInDepCycles,
  )
import FFICXX.Generate.Name
  ( accessorName,
    aliasedFuncName,
    getClassModuleBase,
    getTClassModuleBase,
    hsClassName,
    hsFrontNameForTopLevel,
    hsFuncName,
    hscAccessorName,
    hscFuncName,
    subModuleName,
    typeclassName,
  )
import FFICXX.Generate.Type.Annotate (AnnotateMap)
import FFICXX.Generate.Type.Class
  ( Accessor (..),
    Class (..),
    TLOrdinary (..),
    TLTemplate,
    TopLevel (TLOrdinary),
    Types (..),
    constructorFuncs,
    isAbstractClass,
    isNewFunc,
    isVirtualFunc,
    nonVirtualNotNewFuncs,
    staticFuncs,
    virtualFuncs,
  )
import FFICXX.Generate.Type.Module
  ( ClassModule (..),
    DepCycles,
    TemplateClassModule (..),
  )
import FFICXX.Generate.Util (toLowers)
import FFICXX.Generate.Util.HaskellSrcExts
  ( classA,
    clsDecl,
    con,
    conDecl,
    cxEmpty,
    cxTuple,
    eabs,
    ethingall,
    evar,
    ihcon,
    insDecl,
    insType,
    irule,
    mkBind1,
    mkClass,
    mkData,
    mkDeriving,
    mkFun,
    mkFunSig,
    mkImport,
    mkImportSrc,
    mkInstance,
    mkNewtype,
    mkPVar,
    mkPVarSig,
    mkTBind,
    mkTVar,
    mkVar,
    nonamespace,
    pbind,
    qualConDecl,
    tyForall,
    tyPtr,
    tyapp,
    tycon,
    tyfun,
    unkindedVar,
    unqual,
  )
import Language.Haskell.Exts.Build (app, letE, name, pApp)
import Language.Haskell.Exts.Syntax
  ( Context (CxTuple),
    Decl (..),
    ExportSpec (..),
    ImportDecl (..),
  )
import System.FilePath ((<.>))

genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl Bool
isHsBoot 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
      -- for hs-boot, we only have instance head.
      cdecl' :: Decl ()
cdecl' = Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()
mkClass (() -> [Asst ()] -> Context ()
forall l. l -> [Asst l] -> Context l
CxTuple () []) (Class -> String
typeclassName Class
c) [String -> TyVarBind ()
mkTBind String
"a"] []
      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
  if Bool
isHsBoot
    then Decl () -> Reader AnnotateMap (Decl ())
forall a. a -> ReaderT AnnotateMap Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
cdecl'
    else Decl () -> Reader AnnotateMap (Decl ())
forall a. a -> ReaderT AnnotateMap Identity a
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 ::
  -- | only concrete class
  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 a. a -> ReaderT AnnotateMap Identity a
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 :: TLOrdinary -> [Decl ()]
genTopLevelDef :: TLOrdinary -> [Decl ()]
genTopLevelDef f :: TLOrdinary
f@TopLevelFunction {String
[Arg]
Maybe String
Types
toplevelfunc_ret :: Types
toplevelfunc_name :: String
toplevelfunc_args :: [Arg]
toplevelfunc_alias :: Maybe String
toplevelfunc_ret :: TLOrdinary -> Types
toplevelfunc_name :: TLOrdinary -> String
toplevelfunc_args :: TLOrdinary -> [Arg]
toplevelfunc_alias :: TLOrdinary -> Maybe String
..} =
  let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel (TLOrdinary -> TopLevel
TLOrdinary TLOrdinary
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 a. (a -> a -> a) -> [a] -> a
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 a. [a] -> 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
len Int -> 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 :: TLOrdinary
v@TopLevelVariable {String
Maybe String
Types
toplevelvar_ret :: Types
toplevelvar_name :: String
toplevelvar_alias :: Maybe String
toplevelvar_ret :: TLOrdinary -> Types
toplevelvar_name :: TLOrdinary -> String
toplevelvar_alias :: TLOrdinary -> Maybe String
..} =
  let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel (TLOrdinary -> TopLevel
TLOrdinary TLOrdinary
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 a. [a] -> 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
x String -> String -> String
<.> String
y)) [String
"RawType", String
"Interface", String
"Implementation"]

mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl ()
mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl ()
mkImportWithDepCycles DepCycles
depCycles String
self String
imported =
  let mloc :: Maybe (Int, Int)
mloc = (String, String) -> DepCycles -> Maybe (Int, Int)
locateInDepCycles (String
self, String
imported) DepCycles
depCycles
   in case Maybe (Int, Int)
mloc of
        Just (Int
idxSelf, Int
idxImported)
          | Int
idxImported Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
idxSelf ->
            String -> ImportDecl ()
mkImportSrc String
imported
        Maybe (Int, Int)
_ -> String -> ImportDecl ()
mkImport String
imported

genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()]
genImportInInterface Bool
isHsBoot DepCycles
depCycles ClassModule
m =
  let modSelf :: String
modSelf = ClassModule -> String
cmModule ClassModule
m String -> String -> String
<.> String
"Interface"
      imported :: [UClassSubmodule]
imported = ClassModule -> [UClassSubmodule]
cmImportedSubmodulesForInterface ClassModule
m
      ([String]
rdepsU, [String]
rdepsD) = String -> DepCycles -> ([String], [String])
getCyclicDepSubmodules String
modSelf DepCycles
depCycles
   in if Bool
isHsBoot
        then -- for hs-boot file, we ignore all module imports in the cycle.
        -- TODO: This is likely to be broken in more general cases.
        --       Keep improving this as hs-boot allows.

          let imported' :: [String]
imported' = (UClassSubmodule -> String) -> [UClassSubmodule] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UClassSubmodule -> String
subModuleName [UClassSubmodule]
imported [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ ([String]
rdepsU [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
rdepsD)
           in (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ImportDecl ()
mkImport [String]
imported'
        else (UClassSubmodule -> ImportDecl ())
-> [UClassSubmodule] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DepCycles -> String -> String -> ImportDecl ()
mkImportWithDepCycles DepCycles
depCycles String
modSelf (String -> ImportDecl ())
-> (UClassSubmodule -> String) -> UClassSubmodule -> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassSubmodule -> String
subModuleName) [UClassSubmodule]
imported

-- |
genImportInCast :: ClassModule -> [ImportDecl ()]
genImportInCast :: ClassModule -> [ImportDecl ()]
genImportInCast ClassModule
m =
  (UClassSubmodule -> ImportDecl ())
-> [UClassSubmodule] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ImportDecl ()
mkImport (String -> ImportDecl ())
-> (UClassSubmodule -> String) -> UClassSubmodule -> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassSubmodule -> String
subModuleName) ([UClassSubmodule] -> [ImportDecl ()])
-> [UClassSubmodule] -> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ ClassModule -> [UClassSubmodule]
cmImportedSubmodulesForCast ClassModule
m

genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation ClassModule
m =
  (UClassSubmodule -> ImportDecl ())
-> [UClassSubmodule] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ImportDecl ()
mkImport (String -> ImportDecl ())
-> (UClassSubmodule -> String) -> UClassSubmodule -> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassSubmodule -> String
subModuleName) ([UClassSubmodule] -> [ImportDecl ()])
-> [UClassSubmodule] -> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ ClassModule -> [UClassSubmodule]
cmImportedSubmodulesForImplementation ClassModule
m

-- | generate import list for a given top-level ordinary function
--   currently this may generate duplicate import list.
-- TODO: eliminate duplicated imports.
-- TODO2: should be refactored out.
genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()]
genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()]
genImportForTLOrdinary TLOrdinary
f =
  let dep4func :: Dep4Func
dep4func = TLOrdinary -> Dep4Func
extractClassDepForTLOrdinary TLOrdinary
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]
L.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]
L.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
x String -> 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
x String -> String -> String
<.> String
y)) [String
"Template"]) [String]
tmods

-- | generate import list for a given top-level template function
--   currently this may generate duplicate import list.
-- TODO: eliminate duplicated imports.
-- TODO2: should be refactored out.
genImportForTLTemplate :: TLTemplate -> [ImportDecl ()]
genImportForTLTemplate :: TLTemplate -> [ImportDecl ()]
genImportForTLTemplate TLTemplate
f =
  let dep4func :: Dep4Func
dep4func = TLTemplate -> Dep4Func
extractClassDepForTLTemplate TLTemplate
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]
L.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]
L.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
x String -> 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
x String -> String -> String
<.> String
y)) [String
"Template"]) [String]
tmods

-- | generate import list for top level module
genImportInTopLevel ::
  String ->
  ([ClassModule], [TemplateClassModule]) ->
  [ImportDecl ()]
genImportInTopLevel :: String -> ([ClassModule], [TemplateClassModule]) -> [ImportDecl ()]
genImportInTopLevel String
modname ([ClassModule]
mods, [TemplateClassModule]
_tmods) =
  (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]
++ (String -> ImportDecl ()) -> [String] -> [ImportDecl ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> ImportDecl ()
mkImport [String
modname String -> String -> String
<.> String
"Template", String
modname String -> String -> String
<.> String
"TH", String
modname String -> String -> String
<.> String
"Ordinary"]