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

module FFICXX.Generate.Type.Class where

import           Data.List                         ( intercalate )
import qualified Data.Map                     as M
import           Data.Monoid                       ( Monoid(..) )
import           Data.Semigroup                    ( Semigroup(..), (<>) )
--
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
(Int -> CTypes -> ShowS)
-> (CTypes -> String) -> ([CTypes] -> ShowS) -> Show CTypes
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
(Int -> CPPTypes -> ShowS)
-> (CPPTypes -> String) -> ([CPPTypes] -> ShowS) -> Show CPPTypes
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
(Int -> IsConst -> ShowS)
-> (IsConst -> String) -> ([IsConst] -> ShowS) -> Show IsConst
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
(Int -> TemplateArgType -> ShowS)
-> (TemplateArgType -> String)
-> ([TemplateArgType] -> ShowS)
-> Show TemplateArgType
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
(Int -> TemplateAppInfo -> ShowS)
-> (TemplateAppInfo -> String)
-> ([TemplateAppInfo] -> ShowS)
-> Show TemplateAppInfo
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
  | TemplateApp     TemplateAppInfo  -- ^ like vector<float>*
  | TemplateAppRef  TemplateAppInfo  -- ^ like vector<float>&
  | TemplateAppMove TemplateAppInfo  -- ^ like unique_ptr<float> (using std::move)
  | TemplateType    TemplateClass    -- ^ template self? TODO: clarify this.
  | TemplateParam   String
  | TemplateParamPointer String      -- ^ this is A* with template<A>
  deriving Int -> Types -> ShowS
[Types] -> ShowS
Types -> String
(Int -> Types -> ShowS)
-> (Types -> String) -> ([Types] -> ShowS) -> Show Types
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
(Int -> Arg -> ShowS)
-> (Arg -> String) -> ([Arg] -> ShowS) -> Show Arg
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
(Int -> Function -> ShowS)
-> (Function -> String) -> ([Function] -> ShowS) -> Show Function
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
(Int -> Variable -> ShowS)
-> (Variable -> String) -> ([Variable] -> ShowS) -> Show Variable
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
(Int -> TemplateMemberFunction -> ShowS)
-> (TemplateMemberFunction -> String)
-> ([TemplateMemberFunction] -> ShowS)
-> Show TemplateMemberFunction
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 =
     TopLevelFunction {
       TopLevel -> Types
toplevelfunc_ret :: Types
     , TopLevel -> String
toplevelfunc_name :: String
     , TopLevel -> [Arg]
toplevelfunc_args :: [Arg]
     , TopLevel -> Maybe String
toplevelfunc_alias :: Maybe String
     }
   | TopLevelVariable {
       TopLevel -> Types
toplevelvar_ret :: Types
     , TopLevel -> String
toplevelvar_name :: String
     , TopLevel -> Maybe String
toplevelvar_alias :: Maybe String
     }
   deriving Int -> TopLevel -> ShowS
[TopLevel] -> ShowS
TopLevel -> String
(Int -> TopLevel -> ShowS)
-> (TopLevel -> String) -> ([TopLevel] -> ShowS) -> Show TopLevel
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

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 = (Function -> Bool) -> [Function] -> [Function]
forall a. (a -> Bool) -> [a] -> [a]
filter Function -> Bool
isVirtualFunc

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

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

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

--------

newtype ProtectedMethod = Protected { ProtectedMethod -> [String]
unProtected :: [String] }
                        deriving (b -> ProtectedMethod -> ProtectedMethod
NonEmpty ProtectedMethod -> ProtectedMethod
ProtectedMethod -> ProtectedMethod -> ProtectedMethod
(ProtectedMethod -> ProtectedMethod -> ProtectedMethod)
-> (NonEmpty ProtectedMethod -> ProtectedMethod)
-> (forall b.
    Integral b =>
    b -> ProtectedMethod -> ProtectedMethod)
-> Semigroup 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 :: 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
Semigroup ProtectedMethod
-> ProtectedMethod
-> (ProtectedMethod -> ProtectedMethod -> ProtectedMethod)
-> ([ProtectedMethod] -> ProtectedMethod)
-> Monoid 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
$cp1Monoid :: Semigroup 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 = ShowS
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 String -> String -> Bool
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 = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Class -> String
class_name Class
x) (Class -> String
class_name Class
y)

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

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
    , tfun_name :: String  -- ^ haskell alias for the operator
    , 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 = ShowS
forall a. Show a => a -> String
show (TemplateClass -> String
tclass_name TemplateClass
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
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 String -> String -> Bool
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 = String -> String -> Ordering
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
(Int -> Accessor -> ShowS)
-> (Accessor -> String) -> ([Accessor] -> ShowS) -> Show Accessor
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
(Accessor -> Accessor -> Bool)
-> (Accessor -> Accessor -> Bool) -> Eq Accessor
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)