{-# 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 (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 = forall a b. (a -> b) -> [a] -> [b]
map (Decl () -> ClassDecl ()
clsDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Decl ()
sigdecl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Function] -> [Function]
virtualFuncs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Function]
class_funcs forall a b. (a -> b) -> a -> b
$ Class
c
  if Bool
isHsBoot
    then forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
cdecl'
    else 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 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 (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 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 = forall a b. (a -> b) -> [a] -> [b]
map (Decl () -> InstDecl ()
insDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Decl ()
defn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Function] -> [Function]
virtualFuncs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Function]
class_funcs 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 = forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isNewFunc (Class -> [Function]
class_funcs Class
c)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Function]
fs 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 forall a. Maybe a
Nothing

genHsFrontInstNonVirtual :: Class -> [Decl ()]
genHsFrontInstNonVirtual :: Class -> [Decl ()]
genHsFrontInstNonVirtual Class
c =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Function]
nonvirtualFuncs 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 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 =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Function] -> [Function]
staticFuncs (Class -> [Function]
class_funcs Class
c)) 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 forall a. Maybe a
Nothing

-----

genHsFrontInstVariables :: Class -> [Decl ()]
genHsFrontInstVariables :: Class -> [Decl ()]
genHsFrontInstVariables Class
c =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Class -> [Variable]
class_vars Class
c) 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) forall a. Maybe a
Nothing
          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) forall a. Maybe a
Nothing

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

hsClassRawType :: Class -> [Decl ()]
hsClassRawType :: Class -> [Decl ()]
hsClassRawType Class
c =
  [ String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkData String
rawname [] [] forall a. Maybe a
Nothing,
    String
-> [TyVarBind ()]
-> [QualConDecl ()]
-> Maybe (Deriving ())
-> Decl ()
mkNewtype String
highname [] [Maybe [TyVarBind ()]
-> Maybe (Context ()) -> ConDecl () -> QualConDecl ()
qualConDecl forall a. Maybe a
Nothing 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") 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) 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 = 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 forall a. Maybe a
Nothing 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 forall a. Maybe a
Nothing 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 forall a. Maybe a
Nothing 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" forall a. Semigroup a => a -> a -> a
<> String
highname) Type ()
typ [String -> Pat ()
mkPVar String
"h"] Exp ()
rhs 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
        (forall a. a -> Maybe a
Just [TyVarBind ()
a_bind])
        (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")) 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"))
            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" forall a. Semigroup a => a -> a -> a
<> String
highname) Type ()
typ [String -> Pat ()
mkPVar String
"h"] Exp ()
rhs 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
        (forall a. a -> Maybe a
Just [TyVarBind ()
a_bind])
        (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")) 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")) 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_alias :: TLOrdinary -> Maybe String
toplevelfunc_args :: TLOrdinary -> [Arg]
toplevelfunc_name :: TLOrdinary -> String
toplevelfunc_ret :: TLOrdinary -> Types
toplevelfunc_alias :: Maybe String
toplevelfunc_args :: [Arg]
toplevelfunc_name :: String
toplevelfunc_ret :: Types
..} =
  let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel (TLOrdinary -> TopLevel
TLOrdinary TLOrdinary
f)
      HsFunSig [Type ()]
typs [Asst ()]
assts =
        Maybe Class -> Bool -> CFunSig -> HsFunSig
extractArgRetTypes
          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 forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just ([Asst ()] -> Context ()
cxTuple [Asst ()]
assts)) (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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
toplevelfunc_args in if Int
len forall a. Ord a => a -> a -> Bool
> Int
0 then String
"xform" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Int
len forall a. Num a => a -> a -> a
- Int
1) else String
"xformnull"
      cfname :: String
cfname = String
"c_" 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 forall a. Maybe a
Nothing
genTopLevelDef v :: TLOrdinary
v@TopLevelVariable {String
Maybe String
Types
toplevelvar_alias :: TLOrdinary -> Maybe String
toplevelvar_name :: TLOrdinary -> String
toplevelvar_ret :: TLOrdinary -> Types
toplevelvar_alias :: Maybe String
toplevelvar_name :: String
toplevelvar_ret :: Types
..} =
  let fname :: String
fname = TopLevel -> String
hsFrontNameForTopLevel (TLOrdinary -> TopLevel
TLOrdinary TLOrdinary
v)
      cfname :: String
cfname = String
"c_" forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers String
fname
      rtyp :: Type ()
rtyp = Maybe Class -> Types -> Type ()
convertCpp2HS 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 forall a. Maybe a
Nothing

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

genExport :: Class -> [ExportSpec ()]
genExport :: Class -> [ExportSpec ()]
genExport Class
c =
  let espec :: String -> ExportSpec ()
espec String
n =
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isVirtualFunc) 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 ((forall a b. (a, b) -> a
fst 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" forall a. Semigroup a => a -> a -> a
<> (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> (String, String)
hsClassName) Class
c)),
            QName () -> ExportSpec ()
evar (String -> QName ()
unqual (String
"downcast" forall a. Semigroup a => a -> a -> a
<> (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> (String, String)
hsClassName) Class
c))
          ]
            forall a. Semigroup a => a -> a -> a
<> Class -> [ExportSpec ()]
genExportConstructorAndNonvirtual Class
c
            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 = forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar 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 =
      forall a b. (a -> b) -> [a] -> [b]
map
        (Class -> Function -> String
aliasedFuncName Class
c)
        ( [Function] -> [Function]
constructorFuncs [Function]
fs
            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 = forall a b. (a -> b) -> [a] -> [b]
map (QName () -> ExportSpec ()
evar 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 = 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 = 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 = 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 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' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UClassSubmodule -> String
subModuleName [UClassSubmodule]
imported forall a. Eq a => [a] -> [a] -> [a]
L.\\ ([String]
rdepsU forall a. Semigroup a => a -> a -> a
<> [String]
rdepsD)
           in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ImportDecl ()
mkImport [String]
imported'
        else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DepCycles -> String -> String -> ImportDecl ()
mkImportWithDepCycles DepCycles
depCycles String
modSelf forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassSubmodule -> String
subModuleName) [UClassSubmodule]
imported

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

genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation ClassModule
m =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ImportDecl ()
mkImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassSubmodule -> String
subModuleName) 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 forall a. [a] -> [a] -> [a]
++ Dep4Func -> [Either TemplateClass Class]
argumentDependency Dep4Func
dep4func
      cmods :: [String]
cmods = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Class -> String
getClassModuleBase forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either TemplateClass Class]
ecs
      tmods :: [String]
tmods = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TemplateClass -> String
getTClassModuleBase forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [a]
lefts [Either TemplateClass Class]
ecs
   in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> 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
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> 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 forall a. [a] -> [a] -> [a]
++ Dep4Func -> [Either TemplateClass Class]
argumentDependency Dep4Func
dep4func
      cmods :: [String]
cmods = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Class -> String
getClassModuleBase forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either TemplateClass Class]
ecs
      tmods :: [String]
tmods = forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TemplateClass -> String
getTClassModuleBase forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [a]
lefts [Either TemplateClass Class]
ecs
   in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> 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
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> 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) =
  forall a b. (a -> b) -> [a] -> [b]
map (String -> ImportDecl ()
mkImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> String
cmModule) [ClassModule]
mods
    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> ImportDecl ()
mkImport [String
modname String -> String -> String
<.> String
"Template", String
modname String -> String -> String
<.> String
"TH", String
modname String -> String -> String
<.> String
"Ordinary"]