aos/tools/mackerel/CAbsSyntax.hs

{- 
   CAbsSyntax: combinators for generating C99 syntax
   
  Part of Mackerel: a strawman device definition DSL for Barrelfish
   
  Copyright (c) 2009, 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, Universitaetstrasse 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 Mackerel, etc.
--


tabstop :: String
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)++
          | Parens Expr                 -- (e)
            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 (Parens e) = "(" ++ (pp_expr e) ++ ")"

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
             deriving (Show, Eq)

pp_param :: Param -> String
pp_param (Param t s) = (pp_typespec t s)

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

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


--
-- 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
          | MultiComment [ String ]
          | TypeDef TypeSpec String
          | FunctionDef ScopeSpec TypeSpec String [ Param ] [ Stmt ]
          | StaticInline TypeSpec String [ Param ] [ Stmt ]
          | StructDecl String [ Param ]
          | UnionDecl String [ Param ]
          | EnumDecl String [ EnumItem ]
          | FunctionDecl 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 ]
          | NoOp
          | Blank
          | Include IncludePath String
             deriving (Show, Eq)

pp_unit :: Unit -> [ String ] 
pp_unit (Comment s) = [ "// " ++ s ]
pp_unit (MultiComment 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) = 
    [ hd ++ " __attribute__ ((always_inline));",
      hd ] ++ (pp_fnbody body)
    where 
      hd = "static inline " ++ (pp_fnhead ts n pl)
pp_unit (StructDecl s pl) = 
    [ printf "struct %s {" s ] ++ [ tabstop ++ (pp_param p) ++ ";" 
                                        | p <- pl ] ++ ["};"]
pp_unit (UnionDecl s pl) = 
    [ printf "union %s {" s ] ++ [ tabstop ++ (pp_param p) | p <- pl ] ++ ["}"]
pp_unit (EnumDecl s el) = 
    [ printf "enum %s {" s ] 
    ++ 
    (comma_sep_lines [ tabstop ++ (pp_enumitem e) | e <- el ])
    ++ 
    ["};"]
pp_unit (FunctionDecl ts n pl) =
    [ (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 NoOp = []
pp_unit Blank = [""]
pp_unit (Include s p) = [ pp_include s p ]

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_fnbody :: [ Stmt ] -> [ String ] 
pp_fnbody body = [ "{" ] ++ (indent_stmts body) ++ [ "}", ""]

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

-- 
-- 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
            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 ]

--
-- Type specifiers
--
data TypeSpec = Void
              | Struct String
              | Union String
              | Enum String 
              | Ptr TypeSpec
              | Array Integer TypeSpec
              | TypeName String
              | Function ScopeSpec TypeSpec [ Param ]
                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)