{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module FFICXX.Generate.Name where

import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import FFICXX.Generate.Type.Cabal (cabal_moduleprefix)
import FFICXX.Generate.Type.Class
  ( Accessor (..),
    Arg (..),
    Class (..),
    ClassAlias (caFFIName, caHaskellName),
    Function (..),
    TLOrdinary (..),
    TLTemplate (..),
    TemplateArgType (..),
    TemplateClass (..),
    TemplateFunction (..),
    TemplateMemberFunction (..),
    TopLevel (..),
    Variable (..),
  )
import FFICXX.Generate.Type.Module
  ( ClassSubmoduleType (..),
    TemplateClassSubmoduleType (..),
  )
import FFICXX.Generate.Util (firstLower, toLowers)
import System.FilePath ((<.>))

hsFrontNameForTopLevel :: TopLevel -> String
hsFrontNameForTopLevel :: TopLevel -> String
hsFrontNameForTopLevel TopLevel
tfn =
  let (Char
x : String
xs) = case TopLevel
tfn of
        TLOrdinary 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
        TLOrdinary 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
        TLTemplate TopLevelTemplateFunction {String
[String]
[Arg]
Types
topleveltfunc_params :: [String]
topleveltfunc_ret :: Types
topleveltfunc_name :: String
topleveltfunc_oname :: String
topleveltfunc_args :: [Arg]
topleveltfunc_params :: TLTemplate -> [String]
topleveltfunc_ret :: TLTemplate -> Types
topleveltfunc_name :: TLTemplate -> String
topleveltfunc_oname :: TLTemplate -> String
topleveltfunc_args :: TLTemplate -> [Arg]
..} -> String
topleveltfunc_name
   in Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs

typeclassName :: Class -> String
typeclassName :: Class -> String
typeclassName Class
c = Char
'I' Char -> String -> String
forall a. a -> [a] -> [a]
: (String, String) -> String
forall a b. (a, b) -> a
fst (Class -> (String, String)
hsClassName Class
c)

typeclassNameT :: TemplateClass -> String
typeclassNameT :: TemplateClass -> String
typeclassNameT TemplateClass
c = Char
'I' Char -> String -> String
forall a. a -> [a] -> [a]
: (String, String) -> String
forall a b. (a, b) -> a
fst (TemplateClass -> (String, String)
hsTemplateClassName TemplateClass
c)

typeclassNameFromStr :: String -> String
typeclassNameFromStr :: String -> String
typeclassNameFromStr = (Char
'I' Char -> String -> String
forall a. a -> [a] -> [a]
:)

hsClassName ::
  Class ->
  -- | High-level, 'Raw'-level
  (String, String)
hsClassName :: Class -> (String, String)
hsClassName Class
c =
  let cname :: String
cname = String -> (ClassAlias -> String) -> Maybe ClassAlias -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Class -> String
class_name Class
c) ClassAlias -> String
caHaskellName (Class -> Maybe ClassAlias
class_alias Class
c)
   in (String
cname, String
"Raw" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cname)

hsClassNameForTArg :: TemplateArgType -> String
hsClassNameForTArg :: TemplateArgType -> String
hsClassNameForTArg (TArg_Class Class
c) = (String, String) -> String
forall a b. (a, b) -> a
fst (Class -> (String, String)
hsClassName Class
c)
hsClassNameForTArg (TArg_TypeParam String
p) = String
p
hsClassNameForTArg (TArg_Other String
s) = String
s

hsTemplateClassName ::
  TemplateClass ->
  -- | High-level, 'Raw'-level
  (String, String)
hsTemplateClassName :: TemplateClass -> (String, String)
hsTemplateClassName TemplateClass
t =
  let tname :: String
tname = TemplateClass -> String
tclass_name TemplateClass
t
   in (String
tname, String
"Raw" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tname)

existConstructorName :: Class -> String
existConstructorName :: Class -> String
existConstructorName Class
c = Char
'E' Char -> String -> String
forall 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

ffiClassName :: Class -> String
ffiClassName :: Class -> String
ffiClassName Class
c = String -> (ClassAlias -> String) -> Maybe ClassAlias -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Class -> String
class_name Class
c) ClassAlias -> String
caFFIName (Class -> Maybe ClassAlias
class_alias Class
c)

hscFuncName :: Class -> Function -> String
hscFuncName :: Class -> Function -> String
hscFuncName Class
c Function
f =
  String
"c_"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers (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
<> String -> String
toLowers (Class -> Function -> String
aliasedFuncName Class
c Function
f)

hsFuncName :: Class -> Function -> String
hsFuncName :: Class -> Function -> String
hsFuncName Class
c Function
f =
  let (Char
x : String
xs) = Class -> Function -> String
aliasedFuncName Class
c Function
f
   in (Char -> Char
toLower Char
x) Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs

aliasedFuncName :: Class -> Function -> String
aliasedFuncName :: Class -> Function -> String
aliasedFuncName Class
c Function
f =
  case Function
f of
    Constructor [Arg]
_ Maybe String
a -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Class -> String
constructorName Class
c) Maybe String
a
    Virtual Types
_ String
str [Arg]
_ Maybe String
a -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
str Maybe String
a
    NonVirtual Types
_ String
str [Arg]
_ Maybe String
a -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Class -> String -> String
nonvirtualName Class
c String
str) Maybe String
a
    Static Types
_ String
str [Arg]
_ Maybe String
a -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Class -> String -> String
nonvirtualName Class
c String
str) Maybe String
a
    Destructor Maybe String
a -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
destructorName Maybe String
a

-- |
hsTmplFuncName :: TemplateClass -> TemplateFunction -> String
hsTmplFuncName :: TemplateClass -> TemplateFunction -> String
hsTmplFuncName TemplateClass
t TemplateFunction
f =
  case TemplateFunction
f of
    TFun {String
tfun_name :: String
tfun_name :: TemplateFunction -> String
tfun_name} -> String
tfun_name
    TFunNew {Maybe String
tfun_new_alias :: Maybe String
tfun_new_alias :: TemplateFunction -> Maybe String
tfun_new_alias} -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"new" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TemplateClass -> String
tclass_name TemplateClass
t) Maybe String
tfun_new_alias
    TemplateFunction
TFunDelete -> String
"delete" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TemplateClass -> String
tclass_name TemplateClass
t
    TFunOp {String
tfun_name :: TemplateFunction -> String
tfun_name :: String
tfun_name} -> String
tfun_name

-- |
hsTmplFuncNameTH :: TemplateClass -> TemplateFunction -> String
hsTmplFuncNameTH :: TemplateClass -> TemplateFunction -> String
hsTmplFuncNameTH TemplateClass
t TemplateFunction
f = String
"t_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TemplateClass -> TemplateFunction -> String
hsTmplFuncName TemplateClass
t TemplateFunction
f

hsTemplateMemberFunctionName :: Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName :: Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (Class -> String -> String
nonvirtualName Class
c (TemplateMemberFunction -> String
tmf_name TemplateMemberFunction
f)) (TemplateMemberFunction -> Maybe String
tmf_alias TemplateMemberFunction
f)

hsTemplateMemberFunctionNameTH :: Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionNameTH :: Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionNameTH Class
c TemplateMemberFunction
f = String
"t_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Class -> TemplateMemberFunction -> String
hsTemplateMemberFunctionName Class
c TemplateMemberFunction
f

ffiTmplFuncName :: TemplateFunction -> String
ffiTmplFuncName :: TemplateFunction -> String
ffiTmplFuncName TemplateFunction
f =
  case TemplateFunction
f of
    TFun {String
tfun_name :: TemplateFunction -> String
tfun_name :: String
tfun_name} -> String
tfun_name
    TFunNew {Maybe String
tfun_new_alias :: TemplateFunction -> Maybe String
tfun_new_alias :: Maybe String
tfun_new_alias} -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"new" Maybe String
tfun_new_alias
    TemplateFunction
TFunDelete -> String
"delete"
    TFunOp {String
tfun_name :: TemplateFunction -> String
tfun_name :: String
tfun_name} -> String
tfun_name

cppTmplFuncName :: TemplateFunction -> String
cppTmplFuncName :: TemplateFunction -> String
cppTmplFuncName TemplateFunction
f =
  case TemplateFunction
f of
    TFun {String
tfun_name :: TemplateFunction -> String
tfun_name :: String
tfun_name} -> String
tfun_name
    TFunNew {} -> String
"new"
    TemplateFunction
TFunDelete -> String
"delete"
    TFunOp {String
tfun_name :: TemplateFunction -> String
tfun_name :: String
tfun_name} -> String
tfun_name

-- |
accessorName :: Class -> Variable -> Accessor -> String
accessorName :: Class -> Variable -> Accessor -> String
accessorName Class
c Variable
v Accessor
a =
  Class -> String -> String
nonvirtualName Class
c (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"

-- |
hscAccessorName :: Class -> Variable -> Accessor -> String
hscAccessorName :: Class -> Variable -> Accessor -> String
hscAccessorName Class
c Variable
v Accessor
a = String
"c_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
toLowers (Class -> Variable -> Accessor -> String
accessorName Class
c Variable
v Accessor
a)

-- |
tmplAccessorName :: Variable -> Accessor -> String
tmplAccessorName :: Variable -> Accessor -> String
tmplAccessorName (Variable (Arg Types
_ String
n)) Accessor
a =
  String
n 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"

-- |
cppStaticName :: Class -> Function -> String
cppStaticName :: Class -> Function -> String
cppStaticName Class
c Function
f = Class -> String
class_name Class
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"::" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Function -> String
func_name Function
f

-- |
cppFuncName :: Class -> Function -> String
cppFuncName :: Class -> Function -> String
cppFuncName Class
c Function
f = case Function
f of
  Constructor [Arg]
_ Maybe String
_ -> String
"new"
  Virtual Types
_ String
_ [Arg]
_ Maybe String
_ -> Function -> String
func_name Function
f
  NonVirtual Types
_ String
_ [Arg]
_ Maybe String
_ -> Function -> String
func_name Function
f
  Static Types
_ String
_ [Arg]
_ Maybe String
_ -> Class -> Function -> String
cppStaticName Class
c Function
f
  Destructor Maybe String
_ -> String
destructorName

constructorName :: Class -> String
constructorName :: Class -> String
constructorName Class
c = String
"new" 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

nonvirtualName :: Class -> String -> String
nonvirtualName :: Class -> String -> String
nonvirtualName Class
c String
str = (String -> String
firstLower (String -> String) -> (Class -> String) -> Class -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str

destructorName :: String
destructorName :: String
destructorName = String
"delete"

--
-- Module base and Submodule names in ClassModule
--

getClassModuleBase :: Class -> String
getClassModuleBase :: Class -> String
getClassModuleBase = String -> String -> String
(<.>) (String -> String -> String)
-> (Class -> String) -> Class -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cabal -> String
cabal_moduleprefix (Cabal -> String) -> (Class -> Cabal) -> Class -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> Cabal
class_cabal) (Class -> String -> String) -> (Class -> String) -> Class -> String
forall a b. (Class -> a -> b) -> (Class -> a) -> Class -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((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)

getTClassModuleBase :: TemplateClass -> String
getTClassModuleBase :: TemplateClass -> String
getTClassModuleBase = String -> String -> String
(<.>) (String -> String -> String)
-> (TemplateClass -> String) -> TemplateClass -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cabal -> String
cabal_moduleprefix (Cabal -> String)
-> (TemplateClass -> Cabal) -> TemplateClass -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateClass -> Cabal
tclass_cabal) (TemplateClass -> String -> String)
-> (TemplateClass -> String) -> TemplateClass -> String
forall a b.
(TemplateClass -> a -> b)
-> (TemplateClass -> a) -> TemplateClass -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (TemplateClass -> (String, String)) -> TemplateClass -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateClass -> (String, String)
hsTemplateClassName)

subModuleName ::
  Either
    (TemplateClassSubmoduleType, TemplateClass)
    (ClassSubmoduleType, Class) ->
  String
subModuleName :: Either
  (TemplateClassSubmoduleType, TemplateClass)
  (ClassSubmoduleType, Class)
-> String
subModuleName (Left (TemplateClassSubmoduleType
typ, TemplateClass
tcl)) = String
modBase String -> String -> String
<.> String
submod
  where
    modBase :: String
modBase = TemplateClass -> String
getTClassModuleBase TemplateClass
tcl
    submod :: String
submod = case TemplateClassSubmoduleType
typ of
      TemplateClassSubmoduleType
TCSTTH -> String
"TH"
      TemplateClassSubmoduleType
TCSTTemplate -> String
"Template"
subModuleName (Right (ClassSubmoduleType
typ, Class
cls)) = String
modBase String -> String -> String
<.> String
submod
  where
    modBase :: String
modBase = Class -> String
getClassModuleBase Class
cls
    submod :: String
submod =
      case ClassSubmoduleType
typ of
        ClassSubmoduleType
CSTRawType -> String
"RawType"
        ClassSubmoduleType
CSTInterface -> String
"Interface"
        ClassSubmoduleType
CSTImplementation -> String
"Implementation"
        ClassSubmoduleType
CSTFFI -> String
"FFI"
        ClassSubmoduleType
CSTCast -> String
"Cast"