{-
  CAbsSyntax: Abstract syntax to generate C code for Skate

  Part of Skate: a Schema specification languge

  Copyright (c) 2017, ETH Zurich.
  All rights reserved.

  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group.
-}


module CAbsSyntax where

import Text.Printf
import Data.Char
import Data.List

--
-- Just enough syntax to generate files for Skate, etc.
--


tabstop = "    " -- How much to indent

indent_stmts :: [ Stmt ] -> [ String ]
indent_stmts sl = [ tabstop ++ l | l <- concat [ pp_stmt s | s <- sl ] ]

--
-- We start with expressions
--
data Expr = NumConstant Integer         -- 123
          | HexConstant Integer         -- 0xFF
          | StringConstant String       -- "Hello!"
          | StringCat [ StrElem ]       -- "Value is " PRIu64 " bytes"
          | CharConstant Char           -- 'c'
          | Variable String             -- index
          | AddressOf Expr              -- &foo
          | DerefPtr Expr               -- *foo
          | DerefField Expr String      -- (foo)->string
          | Assignment Expr Expr        -- foo = bar
          | Unary UnOp Expr             -- -(foo)
          | Binary BinOp Expr Expr      -- (a) + (b)
          | Ternary Expr Expr Expr      -- p ? a : b
          | FieldOf Expr String         -- p.field
          | SubscriptOf Expr Expr       -- p[q]
          | Call String [ Expr ]        -- fn(a,b,c)
          | CallInd Expr [ Expr ]       -- (fn)(a,b,c)
          | SizeOf Expr                 -- sizeof(expr)
          | SizeOfT TypeSpec            -- sizeof(int)
          | Cast TypeSpec Expr          -- (foo_t)(expr)
          | PostInc Expr                -- (foo)++
          | PostDec Expr                -- (foo)--
          | PreInc Expr                 -- ++(foo)
          | PreDec Expr                 -- --(foo)
          | Parens Expr                 -- (e)
          | DefineExpr String               -- DEF
          | StructConstant String [(String, Expr)] -- (struct foo){ .field = val, }
          | ArrayConstant [Expr]        -- { val, }
            deriving (Show, Eq)

pp_expr :: Expr -> String
pp_expr (NumConstant i) = printf "%d" i
pp_expr (HexConstant i) = printf "0x%x" i
pp_expr (StringConstant s) = "\"" ++ (concat $ map (\x -> showLitChar x "") s) ++ "\""
pp_expr (StringCat l) = concat $ intersperse " " $ map pp_strelem l
pp_expr (CharConstant c) = "'" ++ showLitChar c "'"
pp_expr (Variable s) = s
pp_expr (AddressOf e) = "&" ++ (pp_par_expr e)
pp_expr (DerefPtr e) = "*" ++ (pp_par_expr e)
pp_expr (DerefField e s) = (pp_par_expr e) ++ "->" ++ s
pp_expr (Assignment e1 e2) = (pp_expr e1) ++ " = " ++ (pp_par_expr e2)
pp_expr (Unary o e) = (pp_unop o) ++ (pp_par_expr e)
pp_expr (Binary o e1 e2)
    = (pp_par_expr e1) ++" " ++ (pp_binop o) ++ " "++(pp_par_expr e2)
pp_expr (Ternary e1 e2 e3)
    = (pp_par_expr e1) ++ " ? " ++ (pp_par_expr e2) ++ " : " ++ (pp_par_expr e3)
pp_expr (FieldOf e s) = (pp_par_expr e) ++ "." ++ s
pp_expr (SubscriptOf e1 e2) = (pp_par_expr e1) ++ "[" ++ (pp_expr e2) ++ "]"
pp_expr (Call f al)
    = f ++ "(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
pp_expr (CallInd f al)
    = "(" ++ (pp_expr f) ++ ")(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
pp_expr (SizeOf e) = "sizeof(" ++ (pp_expr e) ++ ")"
pp_expr (SizeOfT t) = "sizeof(" ++ (pp_typespec t "") ++ ")"
pp_expr (Cast s e) = "(" ++ (pp_typespec s "") ++ ")(" ++ (pp_expr e) ++ ")"
pp_expr (PostInc e) = (pp_par_expr e) ++ "++"
pp_expr (PostDec e) = (pp_par_expr e) ++ "--"
pp_expr (PreInc e) = "++" ++ (pp_par_expr e)
pp_expr (PreDec e) = "--" ++ (pp_par_expr e)
pp_expr (Parens e) = "(" ++ (pp_expr e) ++ ")"
pp_expr (StructConstant n il) = "(struct " ++ n ++ "){ " ++ inits ++ " }"
  where inits = concat $ intersperse ", " [ " ." ++ f ++ " = " ++ pp_expr v | (f,v) <- il ]
pp_expr (ArrayConstant vl) = "{ " ++ (concat $ intersperse ", " (map pp_expr vl)) ++ " }"
pp_expr (DefineExpr str) = str

pp_par_expr :: Expr -> String
pp_par_expr (Variable s) = s
pp_par_expr e@(NumConstant _) = pp_expr e
pp_par_expr e@(HexConstant _) = pp_expr e
pp_par_expr c@(Call _ _) = pp_expr c
pp_par_expr e = "(" ++ (pp_expr e) ++ ")"

data StrElem = QStr String
             | NStr String
               deriving (Show, Eq)

pp_strelem :: StrElem -> String
pp_strelem (QStr s) = pp_expr (StringConstant s)
pp_strelem (NStr s) = s

--
-- Binary operators
--
data BinOp = Plus
           | Minus
           | Times
           | Divide
           | Modulo
           | Equals
           | NotEquals
           | GreaterThan
           | LessThan
           | GreaterThanEq
           | LessThanEq
           | BitwiseAnd
           | BitwiseOr
           | BitwiseXor
           | And
           | Or
           | LeftShift
           | RightShift
             deriving (Show, Eq)

pp_binop :: BinOp -> String
pp_binop Plus = "+"
pp_binop Minus = "-"
pp_binop Times = "*"
pp_binop Divide = "/"
pp_binop Modulo = "%"
pp_binop Equals= "=="
pp_binop NotEquals= "!="
pp_binop GreaterThan= ">"
pp_binop LessThan = "<"
pp_binop GreaterThanEq= ">="
pp_binop LessThanEq= "<="
pp_binop BitwiseAnd= "&"
pp_binop BitwiseOr= "|"
pp_binop BitwiseXor= "^"
pp_binop And= "&&"
pp_binop Or = "||"
pp_binop LeftShift= "<<"
pp_binop RightShift= ">>"

--
-- Unary operators
--
data UnOp = Not | Negate | BitwiseNot
             deriving (Show, Eq)

pp_unop :: UnOp -> String
pp_unop Not = "!"
pp_unop Negate = "-"
pp_unop BitwiseNot = "~"

--
-- Parameters to function definitions
--
data Param = Param TypeSpec String
           | ParamComment String
           | ParamDoxyComment String
           | ParamBlank
             deriving (Show, Eq)

pp_param :: Param -> String
pp_param (Param t s) = (pp_typespec t s)
pp_param (ParamComment s) = "/* " ++ s ++ " */"
pp_param (ParamDoxyComment s) = "///< " ++ s
pp_param ParamBlank = ""

--
-- Members of an enumeration definition
--
data EnumItem = EnumItem String String (Maybe Expr)
             deriving (Show, Eq)

pp_enumitem :: EnumItem -> String
pp_enumitem (EnumItem s d (Just e)) = s ++ " = " ++( pp_expr e) ++ " ///< " ++ d
pp_enumitem (EnumItem s d Nothing) = s ++ " ///< " ++ d


--
-- Include directives
--
data IncludePath = Standard | Local
                   deriving (Show, Eq)
pp_include :: IncludePath -> String -> String
pp_include Standard f = printf "#include <%s>" f
pp_include Local f = printf "#include \"%s\"" f

--
-- Scope of a function or variable
--
data ScopeSpec = Extern | Static | NoScope
                 deriving (Show, Eq)

pp_scopespec :: ScopeSpec -> String
pp_scopespec Extern = "extern "
pp_scopespec Static = "static "
pp_scopespec NoScope = ""

--
-- Constancy
--
data ConstSpec = Const | NonConst
                 deriving (Show, Eq)
pp_constspec :: ConstSpec -> String
pp_constspec Const = "const "
pp_constspec NonConst = ""

--
-- A Unit is a chunk of source file, i.e. top-level syntactic constructs.
--
-- Note that we treat static inlines as their own construct.  It's easier.
--
data Unit = Comment String
          | DoxyComment String
          | MultiComment [ String ]
          | MultiDoxy [ String ]
          | TypeDef TypeSpec String
          | FunctionDef ScopeSpec TypeSpec String [ Param ] [ Stmt ]
          | StaticInline TypeSpec String [ Param ] [ Stmt ]
          | StructDecl String [ Param ]
          | StructForwardDecl String
          | StructDef ScopeSpec String String [ (String, String) ]
          | UnionDecl String [ Param ]
          | UnionForwardDecl String
          | EnumDecl String [ EnumItem ]
          | FunctionDecl ScopeSpec TypeSpec String [ Param ]
          | GVarDecl ScopeSpec ConstSpec TypeSpec String (Maybe Expr)
          | Define String [ String ] String
          | Undef String
          | IfDef String [ Unit ] [ Unit ]
          | IfNDef String [ Unit ] [ Unit ]
          | HashIf String [ Unit ] [ Unit ]
          | UnitList [ Unit ]
          | NoOp
          | Blank
          | Include IncludePath String
             deriving (Show, Eq)

pp_unit :: Unit -> [ String ]
pp_unit (Comment s) = [ "// " ++ s ]
pp_unit (DoxyComment s) = [ "///< " ++ s ]
pp_unit (MultiComment sl) = ["/*"] ++ [ " * " ++ s | s <- sl ] ++ [ " */"]
pp_unit (MultiDoxy sl) = ["/**"] ++ [ " * " ++ s | s <- sl ] ++ [ " */"]
pp_unit (TypeDef ts s) = [ "typedef " ++ (pp_typespec ts s) ++ ";" ]
pp_unit (FunctionDef sc ts n pl body) =
    [ (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl) ] ++ (pp_fnbody body)
pp_unit (StaticInline ts n pl body) =
    [ head ++ " __attribute__ ((always_inline));",
      head ] ++ (pp_fnbody body)
    where
      head = "static inline " ++ (pp_fnhead ts n pl)
pp_unit (StructDecl s pl) =
    [ printf "struct %s {" s ] ++ pp_structunion_body pl ++ ["};"]
pp_unit (StructForwardDecl s) =
    [ printf "struct %s;" s ]
pp_unit (StructDef sc s n fl) =
    [ (pp_scopespec sc) ++ " " ++ (printf "struct %s %s = {" s n)]
    ++ [ tabstop ++ (pp_fieldinit f) | f <- fl ] ++ ["};"]
    where
        pp_fieldinit (n,v) = printf ".%s = %s," n v
pp_unit (UnionDecl s pl) =
    [ printf "union %s {" s ] ++ [ tabstop ++ (pp_param p) ++ ";"
                                        | p <- pl ] ++ ["};"]
pp_unit (UnionForwardDecl s) =
    [ printf "union %s;" s ]
pp_unit (EnumDecl s el) =
    [ printf "typedef enum %s {" s ]
    ++
    (comma_sep_lines [ tabstop ++ (pp_enumitem e) | e <- el ])
    ++
    [ printf "} %s;" s]
pp_unit (FunctionDecl sc ts n pl) =
    [ (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl) ++ ";" ]
pp_unit (GVarDecl sc cs ts s Nothing) =
    [ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
pp_unit (GVarDecl sc cs ts s (Just e)) =
    [ printf "%s%s%s = %s;"
                 (pp_scopespec sc)
                 (pp_constspec cs)
                 (pp_typespec ts s)
                 (pp_expr e) ]
pp_unit (Define n [] v) = [ printf "#define %s %s"  n v ]
pp_unit (Define n al v)
    = [ printf "#define %s(%s) %s" n (concat $ intersperse "," al) v ]
pp_unit (Undef s) = [ "#undef " ++ s ]
pp_unit (IfDef s l r) = pp_cppcond "ifdef" s l r
pp_unit (IfNDef s l r) = pp_cppcond "ifndef" s l r
pp_unit (HashIf s l r) = pp_cppcond "if" s l r
pp_unit (UnitList l) = concat $ map pp_unit l
pp_unit NoOp = []
pp_unit Blank = [""]
pp_unit (Include s p) = [ pp_include s p ]

pp_structunion_body :: [Param] -> [String]
pp_structunion_body pl = [ tabstop ++ (pp_param p) ++ opt_trailer p | p <- pl ]
  where
    opt_trailer (Param _ _) = ";"
    opt_trailer _ = ""

comma_sep_lines :: [String] -> [String]
comma_sep_lines [] = []
comma_sep_lines [s] = [s]
comma_sep_lines (s:sl) = (s ++ ","):(comma_sep_lines sl)

pp_cppcond :: String -> String -> [ Unit ] -> [ Unit ] -> [ String ]
pp_cppcond t e l r =
    [ "#" ++ t ++ " " ++ e ]
    ++
    (concat [ pp_unit u | u <- l ])
    ++
    (if r == [] then [] else "#else":concat [ pp_unit u | u <- r ])
    ++
    [ "#endif // " ++ e ]

pp_cppcond_stmt :: String -> String -> [ Stmt ] -> [ Stmt ] -> [ String ]
pp_cppcond_stmt t e l r =
    [ "#" ++ t ++ " " ++ e ]
    ++
    (concat [ pp_stmt u | u <- l ])
    ++
    (if r == [] then [] else "#else":concat [ pp_stmt u | u <- r ])
    ++
    [ "#endif // " ++ e ]


pp_fnbody :: [ Stmt ] -> [ String ]
pp_fnbody body = [ "{" ] ++ (indent_stmts body) ++ [ "}", ""]

pp_fnhead :: TypeSpec -> String -> [ Param ] -> String
pp_fnhead ts n [] =
    (pp_typespec ts n) ++ "(void)"
pp_fnhead ts n pl =
    (pp_typespec ts n) ++ "(" ++ parlist ++ ")"
    where
      parlist = concat $ intersperse ", " [ pp_param p | p <- pl ]

--
-- Branches of a case statement: note that they fall through
--
data Case = Case Expr [ Stmt ]
            deriving (Show, Eq)

pp_case :: Case -> [ String ]
pp_case (Case e s)
    = [ "case " ++ (pp_expr e) ++ ":" ] ++ (indent_stmts s)

--
-- Statements.
--
data Stmt = Return Expr
          | ReturnVoid
          | Block [ Stmt ]
          | StmtList [ Stmt ]
          | Ex Expr
          | If Expr [ Stmt ] [ Stmt ]
          | DoWhile  Expr [ Stmt ]
          | While Expr [ Stmt ]
          | For Expr Expr Expr [ Stmt ]
          | Switch Expr [ Case ] [ Stmt ]  -- last list is default clause
          | Break
          | Continue
          | Label String
          | Goto String
          | VarDecl ScopeSpec ConstSpec TypeSpec String (Maybe Expr)
          | SComment String
          | SBlank
          | SIfDef String [ Stmt ] [ Stmt ] -- XXX: for #ifdef in the middle of a function
            deriving (Show, Eq)

pp_stmt :: Stmt -> [ String ]
pp_stmt (Return e) = [ "return(" ++ (pp_expr e) ++ ");" ]
pp_stmt ReturnVoid = [ "return;" ]
pp_stmt (Block sl) = [ "{" ] ++ (indent_stmts sl) ++ ["}"]
pp_stmt (StmtList sl) = concat $ map pp_stmt sl
pp_stmt (Ex e) = [ (pp_expr e) ++ ";" ]
pp_stmt (If e sl []) =
    [ "if (" ++ (pp_expr e) ++ ") {" ] ++ (indent_stmts sl) ++ ["}"]
pp_stmt (If e sl1 sl2)
    = [ "if (" ++ (pp_expr e) ++ ") {" ]
      ++ (indent_stmts sl1)
      ++ ["} else {"]
      ++ (indent_stmts sl2) ++ [ "}"]
pp_stmt (DoWhile e sl)
    = [ "do {" ] ++ (indent_stmts sl) ++ [ "} while (" ++ (pp_expr e) ++ ");" ]
pp_stmt (While e sl)
    = [ "while (" ++ (pp_expr e) ++ ") {" ]
      ++ (indent_stmts sl) ++ ["}"]
pp_stmt (For e1 e2 e3 sl)
    = ( [ "for( " ++ (pp_expr e1) ++ "; "
          ++  (pp_expr e2) ++ "; "
          ++ (pp_expr e3) ++ ") {"
        ]
        ++ (indent_stmts sl)
        ++ ["}"]
      )
pp_stmt (Switch e cl sl)
    = ( [ "switch (" ++ (pp_expr e) ++ ") {" ]
        ++ concat [ pp_case c | c <- cl ]
        ++ [ "default:" ]
        ++ (indent_stmts sl)
        ++ [ "}" ]
      )
pp_stmt Break = [ "break;" ]
pp_stmt Continue = [ "continue;" ]
pp_stmt (Label s) = [ s ++ ":" ]
pp_stmt (Goto s) = [ "goto " ++ s ++ ";" ]
pp_stmt (VarDecl sc cs ts s Nothing) =
    [ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
pp_stmt (VarDecl sc cs ts s (Just e)) =
    [ printf "%s%s%s = %s;"
                 (pp_scopespec sc)
                 (pp_constspec cs)
                 (pp_typespec ts s)
                 (pp_expr e) ]
pp_stmt (SComment s) = [ "// " ++ s ]
pp_stmt SBlank = [ "" ]
pp_stmt (SIfDef s l r) = pp_cppcond_stmt "ifdef" s l r

--
-- Type specifiers
--
data TypeSpec = Void
              | Struct String
              | Union String
              | Enum String
              | Ptr TypeSpec
              | Array Integer TypeSpec
              | TypeName String
              | Function ScopeSpec TypeSpec [ Param ]
              -- XXX: hacky way to get qualifiers on a type spec
              | ConstT TypeSpec
              | Volatile TypeSpec
                deriving (Show, Eq)

pp_typespec :: TypeSpec -> String -> String
pp_typespec Void n = "void " ++ n
pp_typespec (Struct s) n = printf "struct %s %s" s n
pp_typespec (Union s) n = printf "union %s %s" s n
pp_typespec (Enum s) n = printf "enum %s %s" s n
pp_typespec (Ptr t) n = pp_typespec t ("*" ++n)
pp_typespec (Array 0 t) n = pp_typespec t (n++"[]")
pp_typespec (Array i t) n = pp_typespec t $ printf "%s[%d]" n i
pp_typespec (TypeName s) n = printf "%s %s" s n
pp_typespec (Function sc ts pl) n
    = (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl)
pp_typespec (ConstT t) n = "const " ++ pp_typespec t n
pp_typespec (Volatile t) n = "volatile " ++ pp_typespec t n