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

module FFICXX.Generate.Type.Class where

import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import FFICXX.Generate.Type.Cabal (Cabal)

-- | C types
data CTypes
  = CTBool
  | CTChar
  | CTClock
  | CTDouble
  | CTFile
  | CTFloat
  | CTFpos
  | CTInt
  | CTIntMax
  | CTIntPtr
  | CTJmpBuf
  | CTLLong
  | CTLong
  | CTPtrdiff
  | CTSChar
  | CTSUSeconds
  | CTShort
  | CTSigAtomic
  | CTSize
  | CTTime
  | CTUChar
  | CTUInt
  | CTUIntMax
  | CTUIntPtr
  | CTULLong
  | CTULong
  | CTUSeconds
  | CTUShort
  | CTWchar
  | CTInt8
  | CTInt16
  | CTInt32
  | CTInt64
  | CTUInt8
  | CTUInt16
  | CTUInt32
  | CTUInt64
  | CTVoidStar
  | CTString
  | CEnum CTypes String
  | CPointer CTypes
  | CRef CTypes
  deriving (Int -> CTypes -> ShowS
[CTypes] -> ShowS
CTypes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CTypes] -> ShowS
$cshowList :: [CTypes] -> ShowS
show :: CTypes -> String
$cshow :: CTypes -> String
showsPrec :: Int -> CTypes -> ShowS
$cshowsPrec :: Int -> CTypes -> ShowS
Show)

-- | C++ types
data CPPTypes
  = CPTClass Class
  | CPTClassRef Class
  | CPTClassCopy Class
  | CPTClassMove Class
  deriving (Int -> CPPTypes -> ShowS
[CPPTypes] -> ShowS
CPPTypes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CPPTypes] -> ShowS
$cshowList :: [CPPTypes] -> ShowS
show :: CPPTypes -> String
$cshow :: CPPTypes -> String
showsPrec :: Int -> CPPTypes -> ShowS
$cshowsPrec :: Int -> CPPTypes -> ShowS
Show)

-- | const flag
data IsConst = Const | NoConst
  deriving (Int -> IsConst -> ShowS
[IsConst] -> ShowS
IsConst -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsConst] -> ShowS
$cshowList :: [IsConst] -> ShowS
show :: IsConst -> String
$cshow :: IsConst -> String
showsPrec :: Int -> IsConst -> ShowS
$cshowsPrec :: Int -> IsConst -> ShowS
Show)

-- | Argument type which can be used as an template argument like float
--   in vector<float>.
--   For now, this distinguishes Class and non-Class.
data TemplateArgType
  = TArg_Class Class
  | TArg_TypeParam String
  | TArg_Other String
  deriving (Int -> TemplateArgType -> ShowS
[TemplateArgType] -> ShowS
TemplateArgType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateArgType] -> ShowS
$cshowList :: [TemplateArgType] -> ShowS
show :: TemplateArgType -> String
$cshow :: TemplateArgType -> String
showsPrec :: Int -> TemplateArgType -> ShowS
$cshowsPrec :: Int -> TemplateArgType -> ShowS
Show)

data TemplateAppInfo = TemplateAppInfo
  { TemplateAppInfo -> TemplateClass
tapp_tclass :: TemplateClass,
    TemplateAppInfo -> [TemplateArgType]
tapp_tparams :: [TemplateArgType],
    TemplateAppInfo -> String
tapp_CppTypeForParam :: String -- TODO: remove this
  }
  deriving (Int -> TemplateAppInfo -> ShowS
[TemplateAppInfo] -> ShowS
TemplateAppInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateAppInfo] -> ShowS
$cshowList :: [TemplateAppInfo] -> ShowS
show :: TemplateAppInfo -> String
$cshow :: TemplateAppInfo -> String
showsPrec :: Int -> TemplateAppInfo -> ShowS
$cshowsPrec :: Int -> TemplateAppInfo -> ShowS
Show)

-- | Supported C++ types.
data Types
  = Void
  | SelfType
  | CT CTypes IsConst
  | CPT CPPTypes IsConst
  | -- | like vector<float>*
    TemplateApp TemplateAppInfo
  | -- | like vector<float>&
    TemplateAppRef TemplateAppInfo
  | -- | like unique_ptr<float> (using std::move)
    TemplateAppMove TemplateAppInfo
  | -- | template self? TODO: clarify this.
    TemplateType TemplateClass
  | TemplateParam String
  | -- | this is A* with template<A>
    TemplateParamPointer String
  deriving (Int -> Types -> ShowS
[Types] -> ShowS
Types -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Types] -> ShowS
$cshowList :: [Types] -> ShowS
show :: Types -> String
$cshow :: Types -> String
showsPrec :: Int -> Types -> ShowS
$cshowsPrec :: Int -> Types -> ShowS
Show)

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

-- | Function argument, type and variable name.
data Arg = Arg
  { Arg -> Types
arg_type :: Types,
    Arg -> String
arg_name :: String
  }
  deriving (Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> String
$cshow :: Arg -> String
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show)

-- | Regular member functions in a ordinary class
data Function
  = Constructor
      { Function -> [Arg]
func_args :: [Arg],
        Function -> Maybe String
func_alias :: Maybe String
      }
  | Virtual
      { Function -> Types
func_ret :: Types,
        Function -> String
func_name :: String,
        func_args :: [Arg],
        func_alias :: Maybe String
      }
  | NonVirtual
      { func_ret :: Types,
        func_name :: String,
        func_args :: [Arg],
        func_alias :: Maybe String
      }
  | Static
      { func_ret :: Types,
        func_name :: String,
        func_args :: [Arg],
        func_alias :: Maybe String
      }
  | Destructor
      { func_alias :: Maybe String
      }
  deriving (Int -> Function -> ShowS
[Function] -> ShowS
Function -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Function] -> ShowS
$cshowList :: [Function] -> ShowS
show :: Function -> String
$cshow :: Function -> String
showsPrec :: Int -> Function -> ShowS
$cshowsPrec :: Int -> Function -> ShowS
Show)

-- | Member variable. Isomorphic to Arg
newtype Variable = Variable {Variable -> Arg
unVariable :: Arg}
  deriving (Int -> Variable -> ShowS
[Variable] -> ShowS
Variable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Variable] -> ShowS
$cshowList :: [Variable] -> ShowS
show :: Variable -> String
$cshow :: Variable -> String
showsPrec :: Int -> Variable -> ShowS
$cshowsPrec :: Int -> Variable -> ShowS
Show)

-- | Member functions of a template class.
data TemplateMemberFunction = TemplateMemberFunction
  { TemplateMemberFunction -> [String]
tmf_params :: [String],
    TemplateMemberFunction -> Types
tmf_ret :: Types,
    TemplateMemberFunction -> String
tmf_name :: String,
    TemplateMemberFunction -> [Arg]
tmf_args :: [Arg],
    TemplateMemberFunction -> Maybe String
tmf_alias :: Maybe String
  }
  deriving (Int -> TemplateMemberFunction -> ShowS
[TemplateMemberFunction] -> ShowS
TemplateMemberFunction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TemplateMemberFunction] -> ShowS
$cshowList :: [TemplateMemberFunction] -> ShowS
show :: TemplateMemberFunction -> String
$cshow :: TemplateMemberFunction -> String
showsPrec :: Int -> TemplateMemberFunction -> ShowS
$cshowsPrec :: Int -> TemplateMemberFunction -> ShowS
Show)

-- | Function defined at top level like ordinary C functions,
--   i.e. no owning class.
data TopLevel
  = TLOrdinary TLOrdinary
  | TLTemplate TLTemplate
  deriving (Int -> TopLevel -> ShowS
[TopLevel] -> ShowS
TopLevel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TopLevel] -> ShowS
$cshowList :: [TopLevel] -> ShowS
show :: TopLevel -> String
$cshow :: TopLevel -> String
showsPrec :: Int -> TopLevel -> ShowS
$cshowsPrec :: Int -> TopLevel -> ShowS
Show)

filterTLOrdinary :: [TopLevel] -> [TLOrdinary]
filterTLOrdinary :: [TopLevel] -> [TLOrdinary]
filterTLOrdinary = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case TLOrdinary TLOrdinary
f -> forall a. a -> Maybe a
Just TLOrdinary
f; TopLevel
_ -> forall a. Maybe a
Nothing)

filterTLTemplate :: [TopLevel] -> [TLTemplate]
filterTLTemplate :: [TopLevel] -> [TLTemplate]
filterTLTemplate = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case TLTemplate TLTemplate
f -> forall a. a -> Maybe a
Just TLTemplate
f; TopLevel
_ -> forall a. Maybe a
Nothing)

data TLOrdinary
  = TopLevelFunction
      { TLOrdinary -> Types
toplevelfunc_ret :: Types,
        TLOrdinary -> String
toplevelfunc_name :: String,
        TLOrdinary -> [Arg]
toplevelfunc_args :: [Arg],
        TLOrdinary -> Maybe String
toplevelfunc_alias :: Maybe String
      }
  | TopLevelVariable
      { TLOrdinary -> Types
toplevelvar_ret :: Types,
        TLOrdinary -> String
toplevelvar_name :: String,
        TLOrdinary -> Maybe String
toplevelvar_alias :: Maybe String
      }
  deriving (Int -> TLOrdinary -> ShowS
[TLOrdinary] -> ShowS
TLOrdinary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TLOrdinary] -> ShowS
$cshowList :: [TLOrdinary] -> ShowS
show :: TLOrdinary -> String
$cshow :: TLOrdinary -> String
showsPrec :: Int -> TLOrdinary -> ShowS
$cshowsPrec :: Int -> TLOrdinary -> ShowS
Show)

data TLTemplate = TopLevelTemplateFunction
  { TLTemplate -> [String]
topleveltfunc_params :: [String],
    TLTemplate -> Types
topleveltfunc_ret :: Types,
    TLTemplate -> String
topleveltfunc_name :: String,
    TLTemplate -> String
topleveltfunc_oname :: String,
    TLTemplate -> [Arg]
topleveltfunc_args :: [Arg]
  }
  deriving (Int -> TLTemplate -> ShowS
[TLTemplate] -> ShowS
TLTemplate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TLTemplate] -> ShowS
$cshowList :: [TLTemplate] -> ShowS
show :: TLTemplate -> String
$cshow :: TLTemplate -> String
showsPrec :: Int -> TLTemplate -> ShowS
$cshowsPrec :: Int -> TLTemplate -> ShowS
Show)

isNewFunc :: Function -> Bool
isNewFunc :: Function -> Bool
isNewFunc (Constructor [Arg]
_ Maybe String
_) = Bool
True
isNewFunc Function
_ = Bool
False

isDeleteFunc :: Function -> Bool
isDeleteFunc :: Function -> Bool
isDeleteFunc (Destructor Maybe String
_) = Bool
True
isDeleteFunc Function
_ = Bool
False

isVirtualFunc :: Function -> Bool
isVirtualFunc :: Function -> Bool
isVirtualFunc (Destructor Maybe String
_) = Bool
True
isVirtualFunc (Virtual Types
_ String
_ [Arg]
_ Maybe String
_) = Bool
True
isVirtualFunc Function
_ = Bool
False

isNonVirtualFunc :: Function -> Bool
isNonVirtualFunc :: Function -> Bool
isNonVirtualFunc (NonVirtual Types
_ String
_ [Arg]
_ Maybe String
_) = Bool
True
isNonVirtualFunc Function
_ = Bool
False

isStaticFunc :: Function -> Bool
isStaticFunc :: Function -> Bool
isStaticFunc (Static Types
_ String
_ [Arg]
_ Maybe String
_) = Bool
True
isStaticFunc Function
_ = Bool
False

virtualFuncs :: [Function] -> [Function]
virtualFuncs :: [Function] -> [Function]
virtualFuncs = forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isVirtualFunc

constructorFuncs :: [Function] -> [Function]
constructorFuncs :: [Function] -> [Function]
constructorFuncs = forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isNewFunc

nonVirtualNotNewFuncs :: [Function] -> [Function]
nonVirtualNotNewFuncs :: [Function] -> [Function]
nonVirtualNotNewFuncs =
  forall a. (a -> Bool) -> [a] -> [a]
filter (\Function
x -> (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Bool
isVirtualFunc) Function
x Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Bool
isNewFunc) Function
x Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Bool
isDeleteFunc) Function
x Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Bool
isStaticFunc) Function
x)

staticFuncs :: [Function] -> [Function]
staticFuncs :: [Function] -> [Function]
staticFuncs = forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isStaticFunc

--------

newtype ProtectedMethod = Protected {ProtectedMethod -> [String]
unProtected :: [String]}
  deriving (NonEmpty ProtectedMethod -> ProtectedMethod
ProtectedMethod -> ProtectedMethod -> ProtectedMethod
forall b. Integral b => b -> ProtectedMethod -> ProtectedMethod
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ProtectedMethod -> ProtectedMethod
$cstimes :: forall b. Integral b => b -> ProtectedMethod -> ProtectedMethod
sconcat :: NonEmpty ProtectedMethod -> ProtectedMethod
$csconcat :: NonEmpty ProtectedMethod -> ProtectedMethod
<> :: ProtectedMethod -> ProtectedMethod -> ProtectedMethod
$c<> :: ProtectedMethod -> ProtectedMethod -> ProtectedMethod
Semigroup, Semigroup ProtectedMethod
ProtectedMethod
[ProtectedMethod] -> ProtectedMethod
ProtectedMethod -> ProtectedMethod -> ProtectedMethod
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ProtectedMethod] -> ProtectedMethod
$cmconcat :: [ProtectedMethod] -> ProtectedMethod
mappend :: ProtectedMethod -> ProtectedMethod -> ProtectedMethod
$cmappend :: ProtectedMethod -> ProtectedMethod -> ProtectedMethod
mempty :: ProtectedMethod
$cmempty :: ProtectedMethod
Monoid)

data ClassAlias = ClassAlias
  { ClassAlias -> String
caHaskellName :: String,
    ClassAlias -> String
caFFIName :: String
  }

-- TODO: partial record must be avoided.
data Class
  = Class
      { Class -> Cabal
class_cabal :: Cabal,
        Class -> String
class_name :: String,
        Class -> [Class]
class_parents :: [Class],
        Class -> ProtectedMethod
class_protected :: ProtectedMethod,
        Class -> Maybe ClassAlias
class_alias :: Maybe ClassAlias,
        Class -> [Function]
class_funcs :: [Function],
        Class -> [Variable]
class_vars :: [Variable],
        Class -> [TemplateMemberFunction]
class_tmpl_funcs :: [TemplateMemberFunction],
        Class -> Bool
class_has_proxy :: Bool
      }
  | AbstractClass
      { class_cabal :: Cabal,
        class_name :: String,
        class_parents :: [Class],
        class_protected :: ProtectedMethod,
        class_alias :: Maybe ClassAlias,
        class_funcs :: [Function],
        class_vars :: [Variable],
        class_tmpl_funcs :: [TemplateMemberFunction]
      }

-- TODO: we had better not override standard definitions
instance Show Class where
  show :: Class -> String
show Class
x = forall a. Show a => a -> String
show (Class -> String
class_name Class
x)

-- TODO: we had better not override standard definitions
instance Eq Class where
  == :: Class -> Class -> Bool
(==) Class
x Class
y = Class -> String
class_name Class
x forall a. Eq a => a -> a -> Bool
== Class -> String
class_name Class
y

-- TODO: we had better not override standard definitions
instance Ord Class where
  compare :: Class -> Class -> Ordering
compare Class
x Class
y = forall a. Ord a => a -> a -> Ordering
compare (Class -> String
class_name Class
x) (Class -> String
class_name Class
y)

data OpExp
  = -- | unary * (deRef) operator
    OpStar
  | -- | unary prefix ++ operator
    --    | OpAdd Arg Arg
    --    | OpMul Arg Arg
    OpFPPlus

data TemplateFunction
  = TFun
      { TemplateFunction -> Types
tfun_ret :: Types,
        TemplateFunction -> String
tfun_name :: String,
        TemplateFunction -> String
tfun_oname :: String,
        TemplateFunction -> [Arg]
tfun_args :: [Arg]
      }
  | TFunNew
      { TemplateFunction -> [Arg]
tfun_new_args :: [Arg],
        TemplateFunction -> Maybe String
tfun_new_alias :: Maybe String
      }
  | TFunDelete
  | TFunOp
      { tfun_ret :: Types,
        -- | haskell alias for the operator
        tfun_name :: String,
        TemplateFunction -> OpExp
tfun_opexp :: OpExp
      }

argsFromOpExp :: OpExp -> [Arg]
argsFromOpExp :: OpExp -> [Arg]
argsFromOpExp OpExp
OpStar = []
argsFromOpExp OpExp
OpFPPlus = []

-- argsFromOpExp (OpAdd x y) = [x,y]
-- argsFromOpExp (OpMul x y) = [x,y]

opSymbol :: OpExp -> String
opSymbol :: OpExp -> String
opSymbol OpExp
OpStar = String
"*"
opSymbol OpExp
OpFPPlus = String
"++"

-- opSymbol (OpAdd _ _) = "+"
-- opSymbol (OpMul _ _) = "*"

-- TODO: Generalize this further.

-- | Positional string interpolation form.
--   For example, "std::map<K,V>::iterator" is FormNested "std::map" "iterator"].
data Form
  = FormSimple String
  | FormNested String String

data TemplateClass = TmplCls
  { TemplateClass -> Cabal
tclass_cabal :: Cabal,
    TemplateClass -> String
tclass_name :: String,
    TemplateClass -> Form
tclass_cxxform :: Form,
    TemplateClass -> [String]
tclass_params :: [String],
    TemplateClass -> [TemplateFunction]
tclass_funcs :: [TemplateFunction],
    TemplateClass -> [Variable]
tclass_vars :: [Variable]
  }

-- TODO: we had better not override standard definitions
instance Show TemplateClass where
  show :: TemplateClass -> String
show TemplateClass
x = forall a. Show a => a -> String
show (TemplateClass -> String
tclass_name TemplateClass
x forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
" " (TemplateClass -> [String]
tclass_params TemplateClass
x))

-- TODO: we had better not override standard definitions
instance Eq TemplateClass where
  == :: TemplateClass -> TemplateClass -> Bool
(==) TemplateClass
x TemplateClass
y = TemplateClass -> String
tclass_name TemplateClass
x forall a. Eq a => a -> a -> Bool
== TemplateClass -> String
tclass_name TemplateClass
y

-- TODO: we had better not override standard definitions
instance Ord TemplateClass where
  compare :: TemplateClass -> TemplateClass -> Ordering
compare TemplateClass
x TemplateClass
y = forall a. Ord a => a -> a -> Ordering
compare (TemplateClass -> String
tclass_name TemplateClass
x) (TemplateClass -> String
tclass_name TemplateClass
y)

data ClassGlobal = ClassGlobal
  { ClassGlobal -> DaughterMap
cgDaughterSelfMap :: DaughterMap,
    ClassGlobal -> DaughterMap
cgDaughterMap :: DaughterMap
  }

data Selfness = Self | NoSelf

-- | Check abstract class
isAbstractClass :: Class -> Bool
isAbstractClass :: Class -> Bool
isAbstractClass Class {} = Bool
False
isAbstractClass AbstractClass {} = Bool
True

-- | Check having Proxy
hasProxy :: Class -> Bool
hasProxy :: Class -> Bool
hasProxy c :: Class
c@Class {} = Class -> Bool
class_has_proxy Class
c
hasProxy AbstractClass {} = Bool
False

type DaughterMap = M.Map String [Class]

data Accessor = Getter | Setter
  deriving (Int -> Accessor -> ShowS
[Accessor] -> ShowS
Accessor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Accessor] -> ShowS
$cshowList :: [Accessor] -> ShowS
show :: Accessor -> String
$cshow :: Accessor -> String
showsPrec :: Int -> Accessor -> ShowS
$cshowsPrec :: Int -> Accessor -> ShowS
Show, Accessor -> Accessor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Accessor -> Accessor -> Bool
$c/= :: Accessor -> Accessor -> Bool
== :: Accessor -> Accessor -> Bool
$c== :: Accessor -> Accessor -> Bool
Eq)