{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module FFICXX.Generate.Code.HsFFI where

import Data.Maybe (fromMaybe, mapMaybe)
import FFICXX.Generate.Code.Primitive
  ( CFunSig (..),
    accessorCFunSig,
    genericFuncArgs,
    genericFuncRet,
    hsFFIFuncTyp,
  )
import FFICXX.Generate.Dependency
  ( class_allparents,
  )
import FFICXX.Generate.Name
  ( aliasedFuncName,
    ffiClassName,
    hscAccessorName,
    hscFuncName,
    subModuleName,
  )
import FFICXX.Generate.Type.Class
  ( Accessor (Getter, Setter),
    Arg (..),
    Class (..),
    Function (..),
    Selfness (NoSelf, Self),
    TLOrdinary (..),
    Variable (unVariable),
    isAbstractClass,
    isNewFunc,
    isStaticFunc,
    virtualFuncs,
  )
import FFICXX.Generate.Type.Module
  ( ClassImportHeader (..),
    ClassModule (..),
    TopLevelImportHeader (..),
  )
import FFICXX.Generate.Util (toLowers)
import FFICXX.Generate.Util.HaskellSrcExts (mkForImpCcall, mkImport)
import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
import Language.Haskell.Exts.Syntax (Decl (..), ImportDecl (..))
import System.FilePath ((<.>))

genHsFFI :: ClassImportHeader -> [Decl ()]
genHsFFI :: ClassImportHeader -> [Decl ()]
genHsFFI ClassImportHeader
header =
  let c :: Class
c = ClassImportHeader -> Class
cihClass ClassImportHeader
header
      -- TODO: This C header information should not be necessary according to up-to-date
      --       version of Haskell FFI.
      h :: HeaderName
h = ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
header
      -- NOTE: We need to generate FFI both for member functions at the current class level
      --       and parent level. For example, consider a class A with method foo, which a
      --       subclass of B with method bar. Then, A::foo (c_a_foo) and A::bar (c_a_bar)
      --       are made into a FFI function.
      allfns :: [Function]
allfns =
        (Class -> [Function]) -> [Class] -> [Function]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          ([Function] -> [Function]
virtualFuncs ([Function] -> [Function])
-> (Class -> [Function]) -> Class -> [Function]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Function]
class_funcs)
          (Class -> [Class]
class_allparents Class
c)
          [Function] -> [Function] -> [Function]
forall a. Semigroup a => a -> a -> a
<> (Class -> [Function]
class_funcs Class
c)
   in (Function -> Maybe (Decl ())) -> [Function] -> [Decl ()]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HeaderName -> Class -> Function -> Maybe (Decl ())
hsFFIClassFunc HeaderName
h Class
c) [Function]
allfns
        [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. Semigroup a => a -> a -> a
<> (Variable -> [Decl ()]) -> [Variable] -> [Decl ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
          (\Variable
v -> [Class -> Variable -> Accessor -> Decl ()
hsFFIAccessor Class
c Variable
v Accessor
Getter, Class -> Variable -> Accessor -> Decl ()
hsFFIAccessor Class
c Variable
v Accessor
Setter])
          (Class -> [Variable]
class_vars Class
c)

hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ())
hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ())
hsFFIClassFunc HeaderName
headerfilename Class
c Function
f =
  if Class -> Bool
isAbstractClass Class
c
    then Maybe (Decl ())
forall a. Maybe a
Nothing
    else
      let hfile :: String
hfile = HeaderName -> String
unHdrName HeaderName
headerfilename
          -- TODO: Make this a separate function
          cname :: String
cname = Class -> String
ffiClassName Class
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Class -> Function -> String
aliasedFuncName Class
c Function
f
          csig :: CFunSig
csig = [Arg] -> Types -> CFunSig
CFunSig (Function -> [Arg]
genericFuncArgs Function
f) (Function -> Types
genericFuncRet Function
f)
          typ :: Type ()
typ =
            if (Function -> Bool
isNewFunc Function
f Bool -> Bool -> Bool
|| Function -> Bool
isStaticFunc Function
f)
              then Maybe (Selfness, Class) -> CFunSig -> Type ()
hsFFIFuncTyp ((Selfness, Class) -> Maybe (Selfness, Class)
forall a. a -> Maybe a
Just (Selfness
NoSelf, Class
c)) CFunSig
csig
              else Maybe (Selfness, Class) -> CFunSig -> Type ()
hsFFIFuncTyp ((Selfness, Class) -> Maybe (Selfness, Class)
forall a. a -> Maybe a
Just (Selfness
Self, Class
c)) CFunSig
csig
       in Decl () -> Maybe (Decl ())
forall a. a -> Maybe a
Just (String -> String -> Type () -> Decl ()
mkForImpCcall (String
hfile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cname) (Class -> Function -> String
hscFuncName Class
c Function
f) Type ()
typ)

hsFFIAccessor :: Class -> Variable -> Accessor -> Decl ()
hsFFIAccessor :: Class -> Variable -> Accessor -> Decl ()
hsFFIAccessor Class
c Variable
v Accessor
a =
  let -- TODO: make this a separate function
      cname :: String
cname = Class -> String
ffiClassName Class
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Arg -> String
arg_name (Variable -> Arg
unVariable Variable
v) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (case Accessor
a of Accessor
Getter -> String
"get"; Accessor
Setter -> String
"set")
      typ :: Type ()
typ = Maybe (Selfness, Class) -> CFunSig -> Type ()
hsFFIFuncTyp ((Selfness, Class) -> Maybe (Selfness, Class)
forall a. a -> Maybe a
Just (Selfness
Self, Class
c)) (Types -> Accessor -> CFunSig
accessorCFunSig (Arg -> Types
arg_type (Variable -> Arg
unVariable Variable
v)) Accessor
a)
   in String -> String -> Type () -> Decl ()
mkForImpCcall String
cname (Class -> Variable -> Accessor -> String
hscAccessorName Class
c Variable
v Accessor
a) Type ()
typ

-- import for FFI
genImportInFFI :: ClassModule -> [ImportDecl ()]
genImportInFFI :: ClassModule -> [ImportDecl ()]
genImportInFFI = (Either
   (TemplateClassSubmoduleType, TemplateClass)
   (ClassSubmoduleType, Class)
 -> ImportDecl ())
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
-> [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 ())
-> (Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)
    -> String)
-> Either
     (TemplateClassSubmoduleType, TemplateClass)
     (ClassSubmoduleType, Class)
-> ImportDecl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> String
subModuleName) ([Either
    (TemplateClassSubmoduleType, TemplateClass)
    (ClassSubmoduleType, Class)]
 -> [ImportDecl ()])
-> (ClassModule
    -> [Either
          (TemplateClassSubmoduleType, TemplateClass)
          (ClassSubmoduleType, Class)])
-> ClassModule
-> [ImportDecl ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule
-> [Either
      (TemplateClassSubmoduleType, TemplateClass)
      (ClassSubmoduleType, Class)]
cmImportedSubmodulesForFFI

----------------------------
-- for top level function --
----------------------------

genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> Decl ()
genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> Decl ()
genTopLevelFFI TopLevelImportHeader
header TLOrdinary
tfn = String -> String -> Type () -> Decl ()
mkForImpCcall (String
hfilename String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" TopLevel_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fname) String
cfname Type ()
typ
  where
    (String
fname, [Arg]
args, Types
ret) =
      case TLOrdinary
tfn of
        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
..} -> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
toplevelfunc_name Maybe String
toplevelfunc_alias, [Arg]
toplevelfunc_args, Types
toplevelfunc_ret)
        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
..} -> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
toplevelvar_name Maybe String
toplevelvar_alias, [], Types
toplevelvar_ret)
    hfilename :: String
hfilename = TopLevelImportHeader -> String
tihHeaderFileName TopLevelImportHeader
header String -> String -> String
<.> String
"h"
    -- TODO: This must be exposed as a top-level function
    cfname :: String
cfname = String
"c_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers String
fname
    typ :: Type ()
typ = Maybe (Selfness, Class) -> CFunSig -> Type ()
hsFFIFuncTyp Maybe (Selfness, Class)
forall a. Maybe a
Nothing ([Arg] -> Types -> CFunSig
CFunSig [Arg]
args Types
ret)