Wrappers.hs

{- |
Module      :  $Header$
Description :  C generation patterns.
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

C generation patterns.
-}

module Language.CAO.Translation.C.Wrappers 
    ( CExtDecl'(..)
    , CTranslUnit'(..)
    , CDecl'(..)
    , declOrMacro
    , cVar
    , cVarDecl
    , cVarIntDecl
    , cVarCharDecl
    , cVarDeclStmt
    , cVarAddr
    , cIntExpr
    , cStringExpr
    , cCharExpr
    , cExprAddr
    , cFuncCall
    , cFuncCallStmt
    , cAssignStmt
    , cCharArrayDecl
    , cIntArrayDecl
    , cTypeArrayDecl
    , cParamDecl
    , cParamDecl'
    , cPointerDecl
    , cPointerCast
    , cPointedExpr
    , cIndirection
    , cFuncDefinition
    , cTypedefDecl
    , cType
    , cReturn
    , cReturnExpr
    , (<<+>)
    , (<+>>)
    , cPointerArrayDecl
    , cExprStmt
    ) where

import Language.C
import Text.PrettyPrint.HughesPJ

-- HACK:
-- Extension and redefinition of the C AST in order to cope with function calls outside
-- function bodies.
-- This is needed for macro declarations of variables and macro declarations of struct fields.
data CExtDecl' = CED CExtDecl | CMacroExt CBlockItem  | CStructExt String String [CDecl']

data CDecl' = 
      CDecl' CDecl
    | CFld CBlockItem  

instance Pretty CDecl' where
    pretty (CDecl' c) = pretty c <> semi
    pretty (CFld b)   = pretty b <> semi

instance Pretty CExtDecl' where
    pretty (CED c) = pretty c
    pretty (CMacroExt m) = pretty m
    pretty (CStructExt tn sn l) = 
        hsep [
            text "typedef",
            vcat [
                text "struct" <+> text sn <+> text "{",
                nest 4 $ sep ( (map pretty l)),
                text "}"
            ]
        ] <+> text tn <> semi

data CTranslUnit' = CTranslUnit' [CExtDecl'] NodeInfo 

instance Pretty CTranslUnit' where
    pretty (CTranslUnit' edecls _) = vcat (map pretty edecls)

declOrMacro :: Either CDecl CBlockItem -> CExtDecl'
declOrMacro = either (CED . CDeclExt) CMacroExt
--------------------------------------------------------------------------------
-- Language.C auxiliary

--------------------------------------------------------------------------------
-- Declarations -- CDeclSpec

-- Short-hand for C void type
cVoidType :: CDeclSpec
cVoidType = CTypeSpec (CVoidType undefNode)

-- Short-hand for C int type
cIntType :: CDeclSpec
cIntType = CTypeSpec (CIntType undefNode) 

-- Short-hand for C char type
cCharType :: CDeclSpec
cCharType = CTypeSpec (CCharType undefNode)

-- Returns a C type with a given name
cType :: String -> CDeclSpec
cType tname = 
    CTypeSpec $ CTypeDef (internalIdent tname) undefNode

-- Constant type qualifier
cConst :: CDeclSpec
cConst = CTypeQual (CConstQual undefNode)

--------------------------------------------------------------------------------
-- Declarations -- CDecl

-- Wrapper for declaring variables without initialization
cVarDecl  :: String -> String -> CDecl
cVarDecl name typ = cParamDecl name (cType typ)

cVarIntDecl :: String -> CDecl
cVarIntDecl name = cParamDecl name cIntType

cVarCharDecl :: String -> CDecl
cVarCharDecl name = cParamDecl name cCharType

-- Wrapper for C typedef definitions
cTypedefDecl :: String -> CDeclSpec -> CDecl
cTypedefDecl tname typ =
    CDecl [CStorageSpec (CTypedef undefNode),typ] [(Just (cDeclr tname []), Nothing, Nothing)] undefNode

-- Wrapper for declaring function parameters
cParamDecl :: String -> CDeclSpec -> CDecl
cParamDecl tname typ =
    CDecl [typ] [(Just (cDeclr tname []), Nothing, Nothing)] undefNode

cParamDecl' :: String -> CDeclSpec -> CDecl'
cParamDecl' tname typ = CDecl' $ cParamDecl tname typ

cPointerDecl :: String -> CDeclSpec -> CDecl
cPointerDecl tname typ = CDecl [typ] [(Just (cDeclr tname [CPtrDeclr [] undefNode]), Nothing, Nothing)] undefNode

cPointer :: CDeclSpec -> CDecl
cPointer typ = CDecl [typ] [(Just (CDeclr Nothing [CPtrDeclr [] undefNode] Nothing [] undefNode), Nothing, Nothing)] undefNode

cDeclr :: String -> [CDerivedDeclr] -> CDeclr
cDeclr nm lst = CDeclr (Just (internalIdent nm)) lst Nothing [] undefNode

--------------------------------------------------------------------------------
-- Statements -- CBlockItem

cAssignStmt :: CExpr -> CExpr -> CBlockItem
cAssignStmt evar cexpr = cExprStmt $ CAssign CAssignOp evar cexpr undefNode

-- Wrapper for C function call statements
cFuncCallStmt :: String -> [CExpr] -> CBlockItem
cFuncCallStmt fname = cExprStmt . cFuncCall fname

-- Wrapper for C expression statements
cExprStmt :: CExpr -> CBlockItem
cExprStmt e = CBlockStmt (CExpr (Just e) undefNode)

-- Default return statement (value OK)
cReturn :: String -> CBlockItem
cReturn caoOk = CBlockStmt $ CReturn (Just (cVar caoOk)) undefNode

cReturnExpr :: CExpr -> CBlockItem
cReturnExpr e = CBlockStmt $ CReturn (Just e) undefNode

cVarDeclStmt :: String -> String -> CBlockItem
cVarDeclStmt name = CBlockDecl . cVarDecl name

cCharArrayDecl :: String -> [CExpr] -> CBlockItem
cCharArrayDecl name = cArrayDecl name [cConst, cCharType] True

cIntArrayDecl :: String -> [CExpr] -> CBlockItem
cIntArrayDecl name = cArrayDecl name [cConst, cIntType] False

cTypeArrayDecl :: String -> String -> [CExpr] -> CBlockItem
cTypeArrayDecl name typ = cArrayDecl name [cType typ] False

cArrayDecl :: String -> [CDeclSpec] -> Bool -> [CExpr] -> CBlockItem
cArrayDecl name qual pointer = cArray qual name dlst
    where
    dlst = cNoArraySize : if pointer then [cNoArraySize] else []

cPointerArrayDecl :: String -> [CExpr] -> CBlockItem
cPointerArrayDecl name = cArray [cVoidType] name dlst
    where
    dlst = [cNoArraySize, CPtrDeclr [] undefNode]

cArray :: [CDeclSpec] -> String -> [CDerivedDeclr] ->  [CExpr] -> CBlockItem
cArray typ name dlst initLst = CBlockDecl $ CDecl typ 
    [ (Just name', Just (CInitList (concatMap initVal initLst) undefNode), Nothing) ]
    undefNode
    where
    name' = cDeclr name dlst 

    initVal :: CExpr -> CInitList
    initVal str = [([], CInitExpr str undefNode)]

cNoArraySize :: CDerivedDeclr
cNoArraySize = CArrDeclr [] (CNoArrSize False) undefNode
--------------------------------------------------------------------------------
-- Expressions -- CExpr

-- Returns a C variable with a given name
{-# INLINE cVar #-}
cVar :: String -> CExpr
cVar name = CVar (internalIdent name) undefNode

-- Wrapper for C function calls
cFuncCall :: String -> [CExpr] -> CExpr
cFuncCall fname args = CCall (cVar fname) args undefNode

-- C literal expression from integer
cIntExpr :: Integer -> CExpr
cIntExpr n = CConst $ CIntConst (cInteger n) undefNode

-- C literal expression from string
cStringExpr :: String -> CExpr
cStringExpr str = CConst $ CStrConst (cString str) undefNode

-- C literal char
cCharExpr :: Char -> CExpr
cCharExpr c = CConst $ CCharConst (cChar c) undefNode

-- Indirection of an expression
cIndirection :: CExpr -> CExpr
cIndirection e = CUnary CIndOp e undefNode

-- Indirection of a pointer cast to int
cPointedExpr :: CExpr -> CExpr
cPointedExpr e = cIndirection (CCast (cPointer cIntType) e undefNode)

-- Cast of a pointer
cPointerCast :: String -> CExpr -> CExpr
cPointerCast typ e = CCast (cPointer (cType typ)) e undefNode

{-# INLINE cVarAddr #-}
cVarAddr :: String -> CExpr
cVarAddr vid = CUnary CAdrOp (cVar vid) undefNode

{-# INLINE cExprAddr #-}
cExprAddr :: CExpr -> CExpr
cExprAddr vid = CUnary CAdrOp vid undefNode

--------------------------------------------------------------------------------
-- Wrapper for defining C functions
cFuncDefinition :: String -> [CDecl] -> String -> CStat -> CFunDef
cFuncDefinition fname cParamDecls caoRes body = let
        prms' = if null cParamDecls 
                    then [CDecl [cVoidType] [] undefNode] 
                    else cParamDecls -- Void for empty parameter list in new style declarations
        funcDecl = cDeclr fname [CFunDeclr (Right (prms', False)) [] undefNode]
    in CFunDef [cType caoRes] funcDecl [] body undefNode

--------------------------------------------------------------------------------
(<+>>) :: CStat -> [CBlockItem] -> CStat
(<+>>) (CCompound a1 lst a2) it = CCompound a1 (lst ++ it) a2
(<+>>) _ _ = error "<CaoToC.h>.<<+>>>: Not expected case"

(<<+>) :: [CBlockItem] -> CStat -> CStat
(<<+>) it (CCompound a1 lst a2) = CCompound a1 (it ++ lst) a2
(<<+>) _ _ = error "<CaoToC.h>.<<<+>>: Not expected case"