cimple-0.0.26: src/Language/Cimple/TreeParser.y
{
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Cimple.TreeParser (parseTranslationUnit) where
import Data.Fix (Fix (..))
import Data.Maybe (maybeToList)
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Cimple.Ast (CommentStyle (..), Node,
NodeF (..))
import Language.Cimple.CommentParser (parseComment)
import Language.Cimple.DescribeAst (describeNode, sloc)
import Language.Cimple.Lexer (Lexeme (..))
import Language.Cimple.ParseResult (ParseResult)
import Language.Cimple.Tokens (LexemeClass (..))
}
%name parseTranslationUnit TranslationUnit
%name parseDecls Decls
%name parseMemberDecls MemberDecls
%error {parseError}
%errorhandlertype explist
%monad {ParseResult}
%tokentype {NonTerm}
%token
ifndefDefine { Fix (PreprocIfndef _ (isDefine -> True) (Fix (PreprocElse []))) }
ifdefDefine { Fix (PreprocIfdef _ (isDefine -> True) (Fix (PreprocElse []))) }
ifDefine { Fix (PreprocIf _ (isDefine -> True) (Fix (PreprocElse []))) }
docComment { Fix (Comment Doxygen _ _ _) }
-- Preprocessor
localIncludeBlock { (isIncludeBlock LitString -> True) }
sysIncludeBlock { (isIncludeBlock LitSysInclude -> True) }
localInclude { Fix (PreprocInclude (L _ LitString _)) }
sysInclude { Fix (PreprocInclude (L _ LitSysInclude _)) }
preprocDefine { Fix (PreprocDefine{}) }
preprocDefineConst { Fix (PreprocDefineConst{}) }
preprocDefineMacro { Fix (PreprocDefineMacro{}) }
preprocIf { Fix (PreprocIf{}) }
preprocIfdef { Fix (PreprocIfdef{}) }
preprocIfndef { Fix (PreprocIfndef{}) }
preprocElse { Fix (PreprocElse{}) }
preprocElif { Fix (PreprocElif{}) }
preprocUndef { Fix (PreprocUndef{}) }
preprocDefined { Fix (PreprocDefined{}) }
preprocScopedDefine { Fix (PreprocScopedDefine{}) }
macroBodyStmt { Fix (MacroBodyStmt{}) }
macroBodyFunCall { Fix (MacroBodyFunCall{}) }
macroParam { Fix (MacroParam{}) }
staticAssert { Fix (StaticAssert{}) }
-- Comments
licenseDecl { Fix (LicenseDecl{}) }
copyrightDecl { Fix (CopyrightDecl{}) }
commentSectionStart { Fix (Comment Section _ _ _) }
commentSectionEnd { Fix (CommentSectionEnd{}) }
comment { Fix (Comment{}) }
commented { Fix (Commented{}) }
-- Namespace-like blocks
externC { Fix (ExternC{}) }
-- Statements
compoundStmt { Fix (CompoundStmt{}) }
break { Fix (Break) }
goto { Fix (Goto{}) }
continue { Fix (Continue) }
return { Fix (Return{}) }
switchStmt { Fix (SwitchStmt{}) }
ifStmt { Fix (IfStmt{}) }
forStmt { Fix (ForStmt{}) }
whileStmt { Fix (WhileStmt{}) }
doWhileStmt { Fix (DoWhileStmt{}) }
case { Fix (Case{}) }
default { Fix (Default{}) }
label { Fix (Label{}) }
exprStmt { Fix (ExprStmt{}) }
-- Variable declarations
vLA { Fix (VLA{}) }
varDeclStmt { Fix (VarDecl{}) }
varDecl { Fix (VarDecl{}) }
declSpecArray { Fix (DeclSpecArray{}) }
-- Expressions
initialiserList { Fix (InitialiserList{}) }
unaryExpr { Fix (UnaryExpr{}) }
binaryExpr { Fix (BinaryExpr{}) }
ternaryExpr { Fix (TernaryExpr{}) }
assignExpr { Fix (AssignExpr{}) }
parenExpr { Fix (ParenExpr{}) }
castExpr { Fix (CastExpr{}) }
compoundLiteral { Fix (CompoundLiteral{}) }
sizeofExpr { Fix (SizeofExpr{}) }
sizeofType { Fix (SizeofType{}) }
literalExpr { Fix (LiteralExpr{}) }
varExpr { Fix (VarExpr{}) }
memberAccess { Fix (MemberAccess{}) }
pointerAccess { Fix (PointerAccess{}) }
arrayAccess { Fix (ArrayAccess{}) }
functionCall { Fix (FunctionCall{}) }
commentExpr { Fix (CommentExpr{}) }
-- Type definitions
enumConsts { Fix (EnumConsts{}) }
enumDecl { Fix (EnumDecl{}) }
enumerator { Fix (Enumerator{}) }
aggregateDecl { Fix (AggregateDecl{}) }
typedefFunction { Fix (TypedefFunction{}) }
typedefStruct { Fix (Typedef (Fix Struct{}) _) }
typedef { Fix (Typedef{}) }
struct { Fix (Struct{}) }
union { Fix (Union{}) }
memberDecl { Fix (MemberDecl{}) }
tyConst { Fix (TyConst{}) }
tyPointer { Fix (TyPointer{}) }
tyStruct { Fix (TyStruct{}) }
tyFunc { Fix (TyFunc{}) }
tyStd { Fix (TyStd{}) }
tyUserDefined { Fix (TyUserDefined{}) }
-- Functions
functionDecl { Fix (FunctionDecl{}) }
functionDefn { Fix (FunctionDefn{}) }
functionPrototype { Fix (FunctionPrototype{}) }
ellipsis { Fix (Ellipsis) }
nonNull { Fix (NonNull{}) }
attrPrintf { Fix (AttrPrintf{}) }
-- Constants
constDecl { Fix (ConstDecl{}) }
constDefn { Fix (ConstDefn{}) }
%%
TranslationUnit :: { [NonTerm] }
TranslationUnit
: licenseDecl Decls { $1 : $2 }
| Decls { $1 }
Decls :: { [NonTerm] }
Decls
: NonEmptyList(Decl) { $1 }
Decl :: { NonTerm }
Decl
: comment { $1 }
| commentSectionStart Decls commentSectionEnd { Fix $ CommentSection $1 $2 $3 }
| CommentableDecl { $1 }
| docComment CommentableDecl {% fmap (\c -> Fix $ Commented c $2) $ parseDocComment $1 }
CommentableDecl :: { NonTerm }
CommentableDecl
: functionDecl { $1 }
| functionDefn { $1 }
| nonNull { $1 }
| attrPrintf { $1 }
| aggregateDecl {% processAggregate $1 }
| struct {% processAggregate $1 }
| union {% processAggregate $1 }
| typedefStruct {% processAggregate $1 }
| typedef { $1 }
| constDecl { $1 }
| constDefn { $1 }
| enumConsts { $1 }
| enumDecl { $1 }
| externC {% recurse parseDecls $1 }
| preprocDefine { $1 }
| preprocDefineConst { $1 }
| preprocDefineMacro { $1 }
| preprocIf {% recurse parseDecls $1 }
| preprocIfdef {% recurse parseDecls $1 }
| preprocIfndef {% recurse parseDecls $1 }
| staticAssert { $1 }
| typedefFunction { $1 }
| ifndefDefine { $1 }
| ifdefDefine { $1 }
| ifDefine { $1 }
| localInclude { $1 }
| localIncludeBlock { $1 }
| sysInclude { $1 }
| sysIncludeBlock { $1 }
MemberDecls :: { [NonTerm] }
MemberDecls
: NonEmptyList(MemberDecl) { $1 }
MemberDecl :: { NonTerm }
MemberDecl
: comment { $1 }
| memberDecl { $1 }
| docComment memberDecl {% fmap (\c -> Fix $ Commented c $2) $ parseDocComment $1 }
| preprocIfdef {% recurse parseMemberDecls $1 }
| preprocIfndef {% recurse parseMemberDecls $1 }
| preprocIf {% recurse parseMemberDecls $1 }
List(x)
: { [] }
| NonEmptyList(x) { $1 }
NonEmptyList(x)
: NonEmptyList_(x) { reverse $1 }
NonEmptyList_(x)
: x { [$1] }
| NonEmptyList_(x) x { $2 : $1 }
{
type TextLexeme = Lexeme Text
type NonTerm = Node TextLexeme
mapHead :: (a -> a) -> [a] -> [a]
mapHead _ [] = []
mapHead f (x:xs) = f x : xs
isDefine :: [NonTerm] -> Bool
isDefine (Fix PreprocUndef{}:d) = isDefine d
isDefine [Fix PreprocDefine{}] = True
isDefine [Fix PreprocDefineConst{}] = True
isDefine _ = False
isIncludeBlock :: LexemeClass -> NonTerm -> Bool
isIncludeBlock style tk@(Fix PreprocIfndef{}) = isPreproc tk && hasInclude style tk
isIncludeBlock style tk@(Fix PreprocIfdef{}) = isPreproc tk && hasInclude style tk
isIncludeBlock style tk@(Fix PreprocIf{}) = isPreproc tk && hasInclude style tk
isIncludeBlock _ _ = False
isPreproc :: NonTerm -> Bool
isPreproc (Fix PreprocInclude{}) = True
isPreproc (Fix PreprocUndef{}) = True
isPreproc (Fix PreprocDefine{}) = True
isPreproc (Fix PreprocDefineConst{}) = True
isPreproc (Fix (PreprocIf _ td ed)) = all isPreproc td && isPreproc ed
isPreproc (Fix (PreprocIfdef _ td ed)) = all isPreproc td && isPreproc ed
isPreproc (Fix (PreprocIfndef _ td ed)) = all isPreproc td && isPreproc ed
isPreproc (Fix (PreprocElse ed)) = all isPreproc ed
isPreproc _ = False
hasInclude :: LexemeClass -> NonTerm -> Bool
hasInclude style (Fix (PreprocInclude (L _ c _))) = c == style
hasInclude style (Fix (PreprocIf _ td ed)) = any (hasInclude style) td || (hasInclude style) ed
hasInclude style (Fix (PreprocIfdef _ td ed)) = any (hasInclude style) td || (hasInclude style) ed
hasInclude style (Fix (PreprocIfndef _ td ed)) = any (hasInclude style) td || (hasInclude style) ed
hasInclude style (Fix (PreprocElse ed)) = any (hasInclude style) ed
hasInclude _ _ = False
-- This helper function unpacks a struct/union, processes its members,
-- and then packs it back up.
processAggregate :: NonTerm -> ParseResult NonTerm
processAggregate (Fix (Struct name members)) = do
processedMembers <- parseMemberDecls members
return $ Fix (Struct name processedMembers)
processAggregate (Fix (Union name members)) = do
processedMembers <- parseMemberDecls members
return $ Fix (Union name processedMembers)
processAggregate (Fix (AggregateDecl agg)) = do
processedAgg <- processAggregate agg
return $ Fix (AggregateDecl processedAgg)
processAggregate (Fix (Typedef agg name)) = do
processedAgg <- processAggregate agg
return $ Fix (Typedef processedAgg name)
processAggregate n = return n -- Return other types unchanged
recurse :: ([NonTerm] -> ParseResult [NonTerm]) -> NonTerm -> ParseResult NonTerm
recurse f (Fix (ExternC ds)) = Fix <$> (ExternC <$> f ds)
recurse f (Fix (PreprocIf c t e)) = Fix <$> (PreprocIf c <$> f t <*> recurse f e)
recurse f (Fix (PreprocIfdef c t e)) = Fix <$> (PreprocIfdef c <$> f t <*> recurse f e)
recurse f (Fix (PreprocIfndef c t e)) = Fix <$> (PreprocIfndef c <$> f t <*> recurse f e)
recurse f (Fix (PreprocElif c t e)) = Fix <$> (PreprocElif c <$> f t <*> recurse f e)
recurse f (Fix (PreprocElse [])) = Fix <$> pure (PreprocElse [])
recurse f (Fix (PreprocElse e)) = Fix <$> (PreprocElse <$> f e)
recurse _ ns = fail $ "TreeParser.recurse: " <> show ns
parseDocComment :: NonTerm -> ParseResult NonTerm
parseDocComment (Fix (Comment Doxygen start body end)) =
Fix . CommentInfo <$> parseComment (start : body ++ [end])
parseDocComment n = return n
failAt :: NonTerm -> String -> ParseResult a
failAt n msg =
fail $ Text.unpack (sloc "" n) <> ": unexpected " <> describeNode n <> msg
parseError :: ([NonTerm], [String]) -> ParseResult a
parseError ([], options) = fail $ " end of file; expected one of " <> show options
parseError (n:_, []) = failAt n "; expected end of file"
parseError (n:_, options) = failAt n $ "; expected one of " <> show options
}