Cxx.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}

module FFICXX.Runtime.CodeGen.Cxx where

import Data.Functor.Identity (Identity)
import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.List (intercalate)
import Data.String (IsString (..))

newtype HeaderName = HdrName {unHdrName :: String}
  deriving (Hashable, Show, Eq, Ord)

instance IsString HeaderName where
  fromString = HdrName

newtype Namespace = NS {unNamespace :: String}
  deriving (Show, Eq, Ord)

instance IsString Namespace where
  fromString = NS

data PragmaParam = Once

-- | parts for interpolation
newtype NamePart (f :: Type -> Type) = NamePart String

newtype CName (f :: Type -> Type) = CName [NamePart f]

sname :: String -> CName Identity
sname s = CName [NamePart s]

renderCName :: CName Identity -> String
renderCName (CName ps) = intercalate "##" $ map (\(NamePart p) -> p) ps

-- | Types
data CType (f :: Type -> Type)
  = CTVoid
  | CTSimple (CName f)
  | CTStar (CType f)
  | CTAuto
  | CTTApp -- template type T<t1,t2,..>
      (CName f)
      -- ^ template type name
      [CType f]
      -- ^ template parameters
  | CTConst (CType f)
  | CTScoped (CType f) (CType f) -- some_class::inner_class
  -- TODO: refine this by restriction
  | CTVerbatim String

-- | Operators
data COp = CArrow | CAssign

renderCOp :: COp -> String
renderCOp CArrow = "->"
renderCOp CAssign = "="

data CExp (f :: Type -> Type)
  = -- | variable
    CVar (CName f)
  | -- | C function app:  f(a1,a2,..)
    CApp (CExp f) [CExp f]
  | -- | template app  :  f<T1,T2,..>(a1,a2,..)
    CTApp (CName f) [CType f] [CExp f]
  | -- | binary operator: x `op` y
    CBinOp COp (CExp f) (CExp f)
  | -- | (type)exp
    CCast (CType f) (CExp f)
  | -- | &(exp)
    CAddr (CExp f)
  | -- | *(exp)
    CStar (CExp f)
  | -- | new operator: new Cstr(a1,a2,...)
    CNew (CName f) [CExp f]
  | -- | new operator for template class: new Cstr<T1,T2,..>(a1,a2,..)
    CTNew (CName f) [CType f] [CExp f]
  | -- | new operator for inner class of template class: new Cstr<T1,T2,..>::inner(a1,a2,..) -- TODO: make a generalization
    CTNewI (CName f) (CName f) [CType f] [CExp f]
  | -- | macro function at expression level
    CEMacroApp (CName f) [CName f]
  | -- | verbatim
    CEVerbatim String
  | -- | empty C expression. (for convenience)
    CNull

data CFunDecl (f :: Type -> Type)
  = -- | type func( type1 arg1, type2 arg2, ... )
    CFunDecl (CType f) (CName f) [(CType f, CName f)]

data CVarDecl (f :: Type -> Type)
  = CVarDecl
      (CType f)
      -- ^ type
      (CName f)
      -- ^ variable name

data CQual = Inline

data CStatement (f :: Type -> Type)
  = -- | using namespace <namespace>;
    UsingNamespace Namespace
  | -- | typedef origtype newname;
    TypeDef (CType f) (CName f)
  | -- | C expression standalone;
    CExpSA (CExp f)
  | -- | function declaration;
    CDeclaration (CFunDecl f)
  | -- | function definition;
    CDefinition (Maybe CQual) (CFunDecl f) [CStatement f]
  | -- | variable initialization;
    CInit (CVarDecl f) (CExp f)
  | -- | return statement;
    CReturn (CExp f)
  | -- | delete statement;
    CDelete (CExp f)
  | -- | C Macro application at statement level (temporary)
    CMacroApp (CName f) [CName f]
  | -- | extern "C" {..}
    CExtern [CStatement f]
  | -- | comment
    Comment String
  | -- | for convenience
    CEmptyLine
  | -- | temporary verbatim
    CVerbatim String

data CMacro (f :: Type -> Type)
  = -- | regular C++ statement
    CRegular (CStatement f)
  | -- | #include "<header>"
    Include HeaderName
  | -- | #pragma
    Pragma PragmaParam
  | -- | #undef name
    Undef (CName f)
  | -- | #define macro (type) definition
    Define (CName f) [CName f] [CStatement f]
  | -- | just for convenience
    EmptyLine
  | -- | temporary verbatim
    Verbatim String

data CBlock (f :: Type -> Type) = ExternC [CMacro f] -- extern "C" with #ifdef __cplusplus guard.

renderPragmaParam :: PragmaParam -> String
renderPragmaParam Once = "once"

renderCType :: CType Identity -> String
renderCType CTVoid = "void"
renderCType (CTSimple n) = renderCName n
renderCType (CTStar t) = renderCType t <> "*"
renderCType CTAuto = "auto"
renderCType (CTTApp n ts) = renderCName n <> "<" <> intercalate ", " (map renderCType ts) <> ">"
renderCType (CTConst t) = "const " <> renderCType t
renderCType (CTScoped t i) = renderCType t <> "::" <> renderCType i
renderCType (CTVerbatim t) = t

renderCExp :: CExp Identity -> String
renderCExp (CVar n) = renderCName n
renderCExp (CApp f es) =
  ( case f of
      CVar _ -> renderCExp f
      _ -> "(" <> renderCExp f <> ")" -- compound expression like (*p)
  )
    <> "("
    <> intercalate ", " (map renderCExp es) -- arguments
    <> ")"
renderCExp (CTApp f ts es) =
  renderCName f
    <> "<"
    <> intercalate ", " (map renderCType ts) -- type arguments
    <> ">"
    <> "("
    <> intercalate ", " (map renderCExp es) -- arguments
    <> ")"
renderCExp (CBinOp o x y) =
  ( case x of
      CVar _ -> renderCExp x
      _ -> "(" <> renderCExp x <> ")" -- compound expression like (*p)
  )
    <> renderCOp o
    <> renderCExp y
renderCExp (CCast t e) = "(" <> renderCType t <> ")" <> renderCExp e
renderCExp (CAddr e) = "&(" <> renderCExp e <> ")"
renderCExp (CStar e) = "*(" <> renderCExp e <> ")"
renderCExp (CNew n es) =
  "new "
    <> renderCName n -- constructor name
    <> "("
    <> intercalate ", " (map renderCExp es) -- arguments
    <> ")"
renderCExp (CTNew n ts es) =
  "new "
    <> renderCName n -- constructor name
    <> "<"
    <> intercalate ", " (map renderCType ts) -- type arguments
    <> ">"
    <> "("
    <> intercalate ", " (map renderCExp es) -- arguments
    <> ")"
renderCExp (CTNewI n i ts es) =
  "new "
    <> renderCName n -- constructor name
    <> "<"
    <> intercalate ", " (map renderCType ts) -- type arguments
    <> ">::"
    <> renderCName i -- inner class name
    <> "("
    <> intercalate ", " (map renderCExp es) -- arguments
    <> ")"
renderCExp (CEMacroApp n as) =
  renderCName n
    <> "("
    <> intercalate ", " (map renderCName as)
    <> ")" -- NOTE: no semicolon.
renderCExp (CEVerbatim e) = e
renderCExp CNull = ""

renderCQual :: CQual -> String
renderCQual Inline = "inline"

renderCFDecl :: CFunDecl Identity -> String
renderCFDecl (CFunDecl typ fname args) =
  renderCType typ <> " " <> renderCName fname <> " ( " <> intercalate ", " (map mkArgStr args) <> " )"
  where
    mkArgStr (t, a) = renderCType t <> " " <> renderCName a

renderCVDecl :: CVarDecl Identity -> String
renderCVDecl (CVarDecl typ vname) = renderCType typ <> " " <> renderCName vname

-- | render CStatement in a regular environment
renderCStmt :: CStatement Identity -> String
renderCStmt (UsingNamespace (NS ns)) = "using namespace " <> ns <> ";"
renderCStmt (TypeDef typ n) = "typedef " <> renderCType typ <> " " <> renderCName n <> ";"
renderCStmt (CExpSA e) = renderCExp e <> ";"
renderCStmt (CDeclaration e) = renderCFDecl e <> ";"
renderCStmt (CDefinition mq d body) =
  maybe "" (\q -> renderCQual q <> " ") mq
    <> renderCFDecl d
    <> " {\n"
    <> concatMap renderCStmt body
    <> "\n}\n"
renderCStmt (CInit d e) = renderCVDecl d <> "=" <> renderCExp e <> ";"
renderCStmt (CReturn e) = "return " <> renderCExp e <> ";"
renderCStmt (CDelete e) = "delete " <> renderCExp e <> ";"
renderCStmt (CMacroApp n as) =
  renderCName n
    <> "("
    <> intercalate ", " (map renderCName as)
    <> ")" -- NOTE: no semicolon.
renderCStmt (CExtern body) =
  "extern \"C\" {\n"
    <> concatMap renderCStmt body
    <> "}\n"
renderCStmt (Comment str) = "// " <> str <> "\n"
renderCStmt CEmptyLine = "\n"
renderCStmt (CVerbatim str) = str

-- | render CStatement in a macro definition environment
renderCStmtInMacro :: CStatement Identity -> [String]
renderCStmtInMacro (Comment _str) = [""] -- Comment cannot exist in Macro
renderCStmtInMacro CEmptyLine = [""]
renderCStmtInMacro (CVerbatim str) = lines str
renderCStmtInMacro s = lines (renderCStmt s)

renderCMacro :: CMacro Identity -> String
renderCMacro (CRegular stmt) = renderCStmt stmt
renderCMacro (Include (HdrName hdr)) = "\n#include \"" <> hdr <> "\"\n"
renderCMacro (Pragma param) = "\n#pragma " <> renderPragmaParam param <> "\n"
renderCMacro (Undef n) = "\n#undef " <> renderCName n <> "\n"
renderCMacro (Define m ts stmts) =
  "\n#define " <> renderCName m
    <> case ts of
      [] -> " "
      _ -> "(" <> intercalate ", " (map renderCName ts) <> ") \\\n"
    <> intercalate "\\\n" (concatMap renderCStmtInMacro stmts)
    <> "\n"
renderCMacro EmptyLine = "\n"
renderCMacro (Verbatim str) = str

renderBlock :: CBlock Identity -> String
renderBlock (ExternC ms) =
  "\n#ifdef __cplusplus\n\
  \extern \"C\" {\n\
  \#endif\n"
    ++ concatMap renderCMacro ms
    ++ "\n#ifdef __cplusplus\n\
       \}\n\
       \#endif\n"