diff --git a/cimple.cabal b/cimple.cabal --- a/cimple.cabal +++ b/cimple.cabal @@ -1,5 +1,5 @@ name: cimple -version: 0.0.1 +version: 0.0.2 synopsis: Simple C-like programming language homepage: https://toktok.github.io/ license: GPL-3 @@ -29,22 +29,40 @@ Language.Cimple , Language.Cimple.Diagnostics , Language.Cimple.IO + , Language.Cimple.Pretty + , Language.Cimple.Program , Language.Cimple.TraverseAst other-modules: Language.Cimple.AST + , Language.Cimple.Graph , Language.Cimple.Lexer , Language.Cimple.Parser + , Language.Cimple.SemCheck.Includes , Language.Cimple.Tokens + , Language.Cimple.TranslationUnit build-depends: base < 5 , aeson + , ansi-wl-pprint , array , bytestring - , compact , containers + , filepath + , groom , mtl , text +executable cimplefmt + default-language: Haskell2010 + hs-source-dirs: + tools + ghc-options: + -Wall + main-is: cimplefmt.hs + build-depends: + base < 5 + , cimple + executable dump-ast default-language: Haskell2010 hs-source-dirs: @@ -73,6 +91,18 @@ , groom , text +executable include-graph + default-language: Haskell2010 + hs-source-dirs: + tools + ghc-options: + -Wall + main-is: include-graph.hs + build-depends: + base < 5 + , cimple + , groom + test-suite testsuite type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -80,10 +110,15 @@ main-is: testsuite.hs other-modules: Language.CimpleSpec + , Language.Cimple.PrettySpec ghc-options: -Wall -fno-warn-unused-imports + build-tool-depends: + hspec-discover:hspec-discover build-depends: base < 5 + , ansi-wl-pprint , cimple , hspec + , text diff --git a/src/Language/Cimple/AST.hs b/src/Language/Cimple/AST.hs --- a/src/Language/Cimple/AST.hs +++ b/src/Language/Cimple/AST.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StrictData #-} module Language.Cimple.AST ( AssignOp (..) , BinaryOp (..) @@ -8,6 +9,7 @@ , LiteralType (..) , Node (..) , Scope (..) + , CommentStyle (..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -24,15 +26,17 @@ | PreprocIfndef lexeme [Node lexeme] (Node lexeme) | PreprocElse [Node lexeme] | PreprocElif (Node lexeme) [Node lexeme] (Node lexeme) - | PreprocError lexeme | PreprocUndef lexeme | PreprocDefined lexeme | PreprocScopedDefine (Node lexeme) [Node lexeme] (Node lexeme) | MacroBodyStmt [Node lexeme] | MacroBodyFunCall (Node lexeme) | MacroParam lexeme + | StaticAssert (Node lexeme) lexeme -- Comments - | Comment [Node lexeme] + | LicenseDecl lexeme [Node lexeme] + | CopyrightDecl lexeme (Maybe lexeme) [lexeme] + | Comment CommentStyle lexeme [Node lexeme] lexeme | CommentBlock lexeme | CommentWord lexeme | Commented (Node lexeme) (Node lexeme) @@ -46,9 +50,9 @@ | Goto lexeme | Continue | Return (Maybe (Node lexeme)) - | Switch (Node lexeme) [Node lexeme] + | SwitchStmt (Node lexeme) [Node lexeme] | IfStmt (Node lexeme) [Node lexeme] (Maybe (Node lexeme)) - | ForStmt (Maybe (Node lexeme)) (Maybe (Node lexeme)) (Maybe (Node lexeme)) [Node lexeme] + | ForStmt (Node lexeme) (Node lexeme) (Node lexeme) [Node lexeme] | WhileStmt (Node lexeme) [Node lexeme] | DoWhileStmt [Node lexeme] (Node lexeme) | Case (Node lexeme) (Node lexeme) @@ -56,7 +60,7 @@ | Label lexeme (Node lexeme) -- Variable declarations | VLA (Node lexeme) lexeme (Node lexeme) - | VarDecl (Node lexeme) [Node lexeme] + | VarDecl (Node lexeme) (Node lexeme) | Declarator (Node lexeme) (Maybe (Node lexeme)) | DeclSpecVar lexeme | DeclSpecArray (Node lexeme) (Maybe (Node lexeme)) @@ -69,6 +73,7 @@ | ParenExpr (Node lexeme) | CastExpr (Node lexeme) (Node lexeme) | SizeofExpr (Node lexeme) + | SizeofType (Node lexeme) | LiteralExpr LiteralType lexeme | VarExpr lexeme | MemberAccess (Node lexeme) lexeme @@ -187,3 +192,12 @@ instance FromJSON Scope instance ToJSON Scope + +data CommentStyle + = Regular + | Doxygen + | Block + deriving (Show, Eq, Generic) + +instance FromJSON CommentStyle +instance ToJSON CommentStyle diff --git a/src/Language/Cimple/Diagnostics.hs b/src/Language/Cimple/Diagnostics.hs --- a/src/Language/Cimple/Diagnostics.hs +++ b/src/Language/Cimple/Diagnostics.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Cimple.Diagnostics (Diagnostics, warn) where +{-# LANGUAGE StrictData #-} +module Language.Cimple.Diagnostics + ( Diagnostics + , warn + ) where import Control.Monad.State.Lazy (State) import qualified Control.Monad.State.Lazy as State diff --git a/src/Language/Cimple/Graph.hs b/src/Language/Cimple/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/Graph.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +module Language.Cimple.Graph + ( Graph + , fromEdges + , edges + ) where + +import qualified Data.Graph as G + +data Graph node key = Graph + { graph :: G.Graph + , nodeFromVertex :: G.Vertex -> (node, key, [key]) + , vertexFromKey :: key -> Maybe G.Vertex + } + +fromEdges :: Ord key => [(node, key, [key])] -> Graph node key +fromEdges es = Graph{..} + where + (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges es + +edges :: Graph node key -> [(key, key)] +edges Graph{..} = map resolve . G.edges $ graph + where + resolve (from, to) = + let + (_, from', _) = nodeFromVertex from + (_, to', _) = nodeFromVertex to + in + (from', to') diff --git a/src/Language/Cimple/IO.hs b/src/Language/Cimple/IO.hs --- a/src/Language/Cimple/IO.hs +++ b/src/Language/Cimple/IO.hs @@ -1,24 +1,28 @@ +{-# LANGUAGE StrictData #-} module Language.Cimple.IO ( parseFile + , parseFiles + , parseProgram , parseText ) where -import Control.Monad.State.Lazy (State, get, put, runState) -import qualified Data.ByteString as BS -import qualified Data.Compact as Compact -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Language.Cimple.AST (Node (..)) -import Language.Cimple.Lexer (Lexeme, runAlex) -import Language.Cimple.Parser (parseCimple) - +import Control.Monad.State.Lazy (State, evalState, get, put) +import qualified Data.ByteString as BS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Language.Cimple.AST (Node (..)) +import Language.Cimple.Lexer (Lexeme, runAlex) +import Language.Cimple.Parser (parseCimple) +import Language.Cimple.Program (Program) +import qualified Language.Cimple.Program as Program +import Language.Cimple.TranslationUnit (TranslationUnit) -type CompactState a = State (Map String Text) a +type CacheState a = State (Map String Text) a -cacheText :: String -> CompactState Text +cacheText :: String -> CacheState Text cacheText s = do m <- get case Map.lookup s m of @@ -30,22 +34,33 @@ return text -process :: [Node (Lexeme String)] -> IO [Node (Lexeme Text)] -process stringAst = do - let (textAst, _) = runState (mapM (mapM (mapM cacheText)) stringAst) Map.empty - Compact.getCompact <$> Compact.compactWithSharing textAst +process :: [Node (Lexeme String)] -> [Node (Lexeme Text)] +process stringAst = + evalState (mapM (mapM (mapM cacheText)) stringAst) Map.empty -parseText :: Text -> IO (Either String [Node (Lexeme Text)]) +parseText :: Text -> Either String [Node (Lexeme Text)] parseText contents = - mapM process res + process <$> res where res :: Either String [Node (Lexeme String)] res = runAlex (Text.unpack contents) parseCimple -parseFile :: FilePath -> IO (Either String [Node (Lexeme Text)]) -parseFile source = do - putStrLn $ "Processing " ++ source - contents <- Text.decodeUtf8 <$> BS.readFile source - parseText contents +parseFile :: FilePath -> IO (Either String (TranslationUnit Text)) +parseFile source = + addSource . parseText . Text.decodeUtf8 <$> BS.readFile source + where + -- Add source filename to the error message, if any. + addSource (Left err) = Left $ "In file \"" <> source <> "\": " <> err + -- If there's no error message, record the source filename in the returned + -- TranslationUnit. + addSource (Right ok) = Right (source, ok) + + +parseFiles :: [FilePath] -> IO (Either String [TranslationUnit Text]) +parseFiles sources = sequenceA <$> traverse parseFile sources + + +parseProgram :: [FilePath] -> IO (Either String (Program Text)) +parseProgram sources = (>>= Program.fromList) <$> parseFiles sources diff --git a/src/Language/Cimple/Lexer.x b/src/Language/Cimple/Lexer.x --- a/src/Language/Cimple/Lexer.x +++ b/src/Language/Cimple/Lexer.x @@ -82,9 +82,8 @@ <0,ppSC> "crypto_box_"[A-Z][A-Z0-9_]* { mkL IdConst } <0,ppSC> "crypto_hash_sha256_"[A-Z][A-Z0-9_]* { mkL IdConst } <0,ppSC> "crypto_hash_sha512_"[A-Z][A-Z0-9_]* { mkL IdConst } +<0,ppSC> "crypto_pwhash_scryptsalsa208sha256_"[A-Z][A-Z0-9_]* { mkL IdConst } <0,ppSC> "crypto_sign_"[A-Z][A-Z0-9_]* { mkL IdConst } -<0> "MAX" { mkL IdConst } -<0> "MIN" { mkL IdConst } -- Standard C (ish). defined { mkL PpDefined } @@ -100,8 +99,9 @@ <0,ppSC> "// ".* ; <0> $white+ ; <0> "//!TOKSTYLE-" { start ignoreSC } -<0> "/*""*"? { mkL CmtStart `andBegin` cmtSC } -<0> "/""*"+\n" *"\n" * :: ".+\n" *"\n" ""*"+"/" { mkL CmtBlock } +<0> "/*" { mkL CmtStart `andBegin` cmtSC } +<0> "/**" { mkL CmtStartDoc `andBegin` cmtSC } +<0> "/**""*"+ { mkL CmtStartBlock `andBegin` cmtSC } <0,cmtSC> \"(\\.|[^\"])*\" { mkL LitString } <0> '(\\|[^'])*' { mkL LitChar } <0> "<"[a-z0-9\.\/_]+">" { mkL LitSysInclude } @@ -114,7 +114,6 @@ <0> "#define" { mkL PpDefine `andBegin` ppSC } <0> "#undef" { mkL PpUndef } <0> "#include" { mkL PpInclude } -<0> "#error" { mkL PpError } <0,ppSC> "bitmask" { mkL KwBitmask } <0,ppSC> "break" { mkL KwBreak } <0,ppSC> "case" { mkL KwCase } @@ -135,6 +134,7 @@ <0,ppSC> "return" { mkL KwReturn } <0,ppSC> "sizeof" { mkL KwSizeof } <0,ppSC> "static" { mkL KwStatic } +<0,ppSC> "static_assert" { mkL KwStaticAssert } <0,ppSC> "struct" { mkL KwStruct } <0,ppSC> "switch" { mkL KwSwitch } <0,ppSC> "this" { mkL KwThis } @@ -233,15 +233,19 @@ "http://"[^ ]+ { mkL CmtWord } [0-9]+"%" { mkL LitInteger } "`"([^`]|"\`")+"`" { mkL CmtCode } + "–" { mkL CmtWord } "*/" { mkL CmtEnd `andBegin` 0 } - \n" "+"*/" { mkL CmtEnd `andBegin` 0 } - \n" "+"*" { mkL PpNewline } - \n { mkL PpNewline } + \n { mkL PpNewline `andBegin` cmtNewlineSC } " "+ ; + " "+"*"+"/" { mkL CmtEnd `andBegin` 0 } + " "+"*" { mkL CmtIndent `andBegin` cmtSC } + -- blocks in comments. "@endcode" { mkL CmtCode `andBegin` cmtSC } "" { mkL CmtCode `andBegin` cmtSC } + \n { mkL PpNewline } + \n" "+"*" { mkL PpNewline } [^@\<]+ { mkL CmtCode } -- Error handling. diff --git a/src/Language/Cimple/Parser.y b/src/Language/Cimple/Parser.y --- a/src/Language/Cimple/Parser.y +++ b/src/Language/Cimple/Parser.y @@ -2,8 +2,8 @@ module Language.Cimple.Parser where import Language.Cimple.AST (AssignOp (..), BinaryOp (..), - LiteralType (..), Node (..), - Scope (..), UnaryOp (..)) + CommentStyle (..), LiteralType (..), + Node (..), Scope (..), UnaryOp (..)) import Language.Cimple.Lexer (Alex, AlexPosn, Lexeme (..), alexError, alexMonadScan) import Language.Cimple.Tokens (LexemeClass (..)) @@ -14,6 +14,7 @@ %name parseCimple %error {parseError} +%errorhandlertype explist %lexer {lexwrap} {L _ Eof _} %monad {Alex} %tokentype {Lexeme String} @@ -44,6 +45,7 @@ return { L _ KwReturn _ } sizeof { L _ KwSizeof _ } static { L _ KwStatic _ } + static_assert { L _ KwStaticAssert _ } struct { L _ KwStruct _ } switch { L _ KwSwitch _ } this { L _ KwThis _ } @@ -110,7 +112,6 @@ '#elif' { L _ PpElif _ } '#else' { L _ PpElse _ } '#endif' { L _ PpEndif _ } - '#error' { L _ PpError _ } '#if' { L _ PpIf _ } '#ifdef' { L _ PpIfdef _ } '#ifndef' { L _ PpIfndef _ } @@ -119,12 +120,15 @@ '\n' { L _ PpNewline _ } '/**/' { L _ CmtBlock _ } '/*' { L _ CmtStart _ } + '/**' { L _ CmtStartDoc _ } + '/***' { L _ CmtStartBlock _ } + ' * ' { L _ CmtIndent _ } '*/' { L _ CmtEnd _ } 'Copyright' { L _ CmtSpdxCopyright _ } 'License' { L _ CmtSpdxLicense _ } - COMMENT_CODE { L _ CmtCode _ } - COMMENT_WORD { L _ CmtWord _ } - COMMENT_REF { L _ CmtRef _ } + CMT_CODE { L _ CmtCode _ } + CMT_WORD { L _ CmtWord _ } + CMT_REF { L _ CmtRef _ } %left ',' %right '=' '+=' '-=' '*=' '/=' '%=' '<<=' '>>=' '&=' '^=' '|=' @@ -146,155 +150,194 @@ TranslationUnit :: { [StringNode] } TranslationUnit -: ToplevelDecls { reverse $1 } +: ToplevelDecls { reverse $1 } +| LicenseDecl ToplevelDecls { $1 : reverse $2 } +LicenseDecl :: { StringNode } +LicenseDecl +: '/*' 'License' CMT_WORD '\n' CopyrightDecls '*/' { LicenseDecl $3 $5 } + +CopyrightDecls :: { [StringNode] } +CopyrightDecls +: CopyrightDecl { [$1] } +| CopyrightDecls CopyrightDecl { $2 : $1 } + +CopyrightDecl :: { StringNode } +CopyrightDecl +: ' * ' 'Copyright' CopyrightDates CopyrightOwner '\n' { CopyrightDecl (fst $3) (snd $3) $4 } + +CopyrightDates :: { (StringLexeme, Maybe StringLexeme) } +CopyrightDates +: LIT_INTEGER { ($1, Nothing) } +| LIT_INTEGER '-' LIT_INTEGER { ($1, Just $3) } + +CopyrightOwner :: { [StringLexeme] } +CopyrightOwner +: CMT_WORD CommentWords { $1 : reverse $2 } + ToplevelDecls :: { [StringNode] } ToplevelDecls -: ToplevelDecl { [$1] } -| ToplevelDecls ToplevelDecl { $2 : $1 } +: ToplevelDecl { [$1] } +| ToplevelDecls ToplevelDecl { $2 : $1 } ToplevelDecl :: { StringNode } ToplevelDecl -: PreprocIfdef(ToplevelDecls) { $1 } -| PreprocIf(ToplevelDecls) { $1 } -| PreprocInclude { $1 } -| PreprocDefine { $1 } -| PreprocUndef { $1 } -| PreprocError { $1 } -| ExternC { $1 } -| TypedefDecl { $1 } -| AggregateDecl { $1 } -| EnumDecl { $1 } -| FunctionDecl { $1 } -| ConstDecl { $1 } -| Comment { $1 } -| Namespace { $1 } -| Event { $1 } -| ErrorDecl { $1 } +: PreprocIfdef(ToplevelDecls) { $1 } +| PreprocIf(ToplevelDecls) { $1 } +| PreprocInclude { $1 } +| PreprocUndef { $1 } +| ExternC { $1 } +| Comment { $1 } +| Namespace { $1 } +| Event { $1 } +| ErrorDecl { $1 } +| StaticAssert { $1 } +| Commented(CommentableDecl) { $1 } +CommentableDecl :: { StringNode } +CommentableDecl +: TypedefDecl { $1 } +| AggregateDecl { $1 } +| EnumDecl { $1 } +| FunctionDecl { $1 } +| ConstDecl { $1 } +| PreprocDefine { $1 } + +DocComment :: { StringNode } +DocComment +: '/**' CommentTokens '*/' { Comment Doxygen $1 (reverse $2) $3 } + +StaticAssert :: { StringNode } +StaticAssert +: static_assert '(' ConstExpr ',' LIT_STRING ')' ';' { StaticAssert $3 $5 } + Namespace :: { StringNode } Namespace -: NamespaceDeclarator { $1 Global } -| static NamespaceDeclarator { $2 Static } +: NamespaceDeclarator { $1 Global } +| static NamespaceDeclarator { $2 Static } NamespaceDeclarator :: { Scope -> StringNode } NamespaceDeclarator -: class ID_SUE_TYPE TypeParams '{' ToplevelDecls '}' { \s -> Class s $2 $3 $5 } -| namespace IdVar '{' ToplevelDecls '}' { \s -> Namespace s $2 $4 } +: class ID_SUE_TYPE TypeParams '{' ToplevelDecls '}' { \s -> Class s $2 $3 (reverse $5) } +| namespace IdVar '{' ToplevelDecls '}' { \s -> Namespace s $2 (reverse $4) } TypeParams :: { [StringNode] } TypeParams -: { [] } -| '<' ID_TYVAR '>' { [TyVar $2] } +: { [] } +| '<' ID_TYVAR '>' { [TyVar $2] } Event :: { StringNode } Event -: event IdVar '{' EventType '}' { Event $2 $4 } -| event IdVar const '{' EventType '}' { Event $2 $5 } +: event IdVar '{' Commented(EventType) '}' { Event $2 $4 } +| event IdVar const '{' Commented(EventType) '}' { Event $2 $5 } EventType :: { StringNode } EventType -: Comment typedef void EventParams ';' { Commented $1 $4 } +: typedef void EventParams ';' { $3 } EventParams :: { StringNode } EventParams -: FunctionParamList { EventParams $1 } +: FunctionParamList { EventParams $1 } ErrorDecl :: { StringNode } ErrorDecl -: 'error' for IdVar EnumeratorList { ErrorDecl $3 $4 } +: 'error' for IdVar EnumeratorList { ErrorDecl $3 $4 } Comment :: { StringNode } Comment -: '/*' CommentBody '*/' { Comment (reverse $2) } -| '/**/' { CommentBlock $1 } +: '/*' CommentTokens '*/' { Comment Regular $1 (reverse $2) $3 } +| '/***' CommentTokens '*/' { Comment Block $1 (reverse $2) $3 } +| '/**/' { CommentBlock $1 } -CommentBody :: { [StringNode] } -CommentBody -: CommentWord { [$1] } -| CommentBody CommentWord { $2 : $1 } +CommentTokens :: { [StringNode] } +CommentTokens +: CommentToken { [$1] } +| CommentTokens CommentToken { $2 : $1 } -CommentWord :: { StringNode } +CommentToken :: { StringNode } +CommentToken +: CommentWord { CommentWord $1 } +| '\n' { CommentWord $1 } +| ' * ' { CommentWord $1 } + +CommentWords :: { [StringLexeme] } +CommentWords +: { [] } +| CommentWords CommentWord { $2 : $1 } + +CommentWord :: { StringLexeme } CommentWord -: COMMENT_WORD { CommentWord $1 } -| COMMENT_REF { CommentWord $1 } -| COMMENT_CODE { CommentWord $1 } -| LIT_INTEGER { CommentWord $1 } -| LIT_STRING { CommentWord $1 } -| 'Copyright' { CommentWord $1 } -| 'License' { CommentWord $1 } -| '.' { CommentWord $1 } -| '?' { CommentWord $1 } -| '!' { CommentWord $1 } -| ',' { CommentWord $1 } -| ';' { CommentWord $1 } -| ':' { CommentWord $1 } -| '(' { CommentWord $1 } -| ')' { CommentWord $1 } -| '<' { CommentWord $1 } -| '>' { CommentWord $1 } -| '/' { CommentWord $1 } -| '+' { CommentWord $1 } -| '-' { CommentWord $1 } -| '=' { CommentWord $1 } -| '\n' { CommentWord $1 } +: CMT_WORD { $1 } +| CMT_REF { $1 } +| CMT_CODE { $1 } +| LIT_INTEGER { $1 } +| LIT_STRING { $1 } +| '.' { $1 } +| '?' { $1 } +| '!' { $1 } +| ',' { $1 } +| ';' { $1 } +| ':' { $1 } +| '(' { $1 } +| ')' { $1 } +| '<' { $1 } +| '>' { $1 } +| '/' { $1 } +| '+' { $1 } +| '-' { $1 } +| '=' { $1 } PreprocIfdef(decls) -: '#ifdef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfdef $2 $3 $4 } -| '#ifndef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfndef $2 $3 $4 } +: '#ifdef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfdef $2 (reverse $3) $4 } +| '#ifndef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfndef $2 (reverse $3) $4 } PreprocIf(decls) -: '#if' ConstExpr '\n' decls PreprocElse(decls) '#endif' { PreprocIf $2 $4 $5 } +: '#if' PreprocConstExpr '\n' decls PreprocElse(decls) '#endif' { PreprocIf $2 (reverse $4) $5 } PreprocElse(decls) -: { PreprocElse [] } -| '#else' decls { PreprocElse $2 } -| '#elif' ConstExpr '\n' decls PreprocElse(decls) { PreprocElif $2 $4 $5 } - -PreprocError :: { StringNode } -PreprocError -: '#error' LIT_STRING { PreprocError $2 } +: { PreprocElse [] } +| '#else' decls { PreprocElse $2 } +| '#elif' PreprocConstExpr '\n' decls PreprocElse(decls) { PreprocElif $2 (reverse $4) $5 } PreprocInclude :: { StringNode } PreprocInclude -: '#include' LIT_STRING { PreprocInclude $2 } -| '#include' LIT_SYS_INCLUDE { PreprocInclude $2 } +: '#include' LIT_STRING { PreprocInclude $2 } +| '#include' LIT_SYS_INCLUDE { PreprocInclude $2 } PreprocDefine :: { StringNode } PreprocDefine -: '#define' ID_CONST '\n' { PreprocDefine $2 } -| '#define' ID_CONST ConstExpr '\n' { PreprocDefineConst $2 $3 } -| '#define' ID_CONST MacroParamList MacroBody '\n' { PreprocDefineMacro $2 $3 $4 } +: '#define' ID_CONST '\n' { PreprocDefine $2 } +| '#define' ID_CONST PreprocSafeExpr(ConstExpr) '\n' { PreprocDefineConst $2 $3 } +| '#define' ID_CONST MacroParamList MacroBody '\n' { PreprocDefineMacro $2 $3 $4 } PreprocUndef :: { StringNode } PreprocUndef -: '#undef' ID_CONST { PreprocUndef $2 } +: '#undef' ID_CONST { PreprocUndef $2 } -ConstExpr :: { StringNode } -ConstExpr -: LiteralExpr { $1 } -| 'defined' '(' ID_CONST ')' { PreprocDefined $3 } -| PureExpr(ConstExpr) { $1 } +PreprocConstExpr :: { StringNode } +PreprocConstExpr +: PureExpr(PreprocConstExpr) { $1 } +| 'defined' '(' ID_CONST ')' { PreprocDefined $3 } MacroParamList :: { [StringNode] } MacroParamList -: '(' ')' { [] } -| '(' MacroParams ')' { reverse $2 } -| '(' MacroParams ',' '...' ')' { reverse $ Ellipsis : $2 } +: '(' ')' { [] } +| '(' MacroParams ')' { reverse $2 } +| '(' MacroParams ',' '...' ')' { reverse $ Ellipsis : $2 } MacroParams :: { [StringNode] } MacroParams -: MacroParam { [$1] } -| MacroParams ',' MacroParam { $3 : $1 } +: MacroParam { [$1] } +| MacroParams ',' MacroParam { $3 : $1 } MacroParam :: { StringNode } MacroParam -: IdVar { MacroParam $1 } +: IdVar { MacroParam $1 } MacroBody :: { StringNode } MacroBody -: do CompoundStmt while '(' LIT_INTEGER ')' {% macroBodyStmt $2 $5 } -| FunctionCall { MacroBodyFunCall $1 } +: do CompoundStmt while '(' LIT_INTEGER ')' {% macroBodyStmt $2 $5 } +| FunctionCall { MacroBodyFunCall $1 } ExternC :: { StringNode } ExternC @@ -304,368 +347,388 @@ ToplevelDecls '#ifdef' ID_CONST '}' - '#endif' {% externC $2 $4 $7 $9 } + '#endif' {% externC $2 $4 (reverse $7) $9 } Stmts :: { [StringNode] } Stmts -: Stmt { [$1] } -| Stmts Stmt { $2 : $1 } +: Stmt { [$1] } +| Stmts Stmt { $2 : $1 } Stmt :: { StringNode } Stmt -: PreprocIfdef(Stmts) { $1 } -| PreprocIf(Stmts) { $1 } -| PreprocDefine Stmts PreprocUndef { PreprocScopedDefine $1 $2 $3 } -| LabelStmt { $1 } -| DeclStmt { $1 } -| CompoundStmt { CompoundStmt $1 } -| IfStmt { $1 } -| ForStmt { $1 } -| WhileStmt { $1 } -| DoWhileStmt { $1 } -| AssignExpr ';' { $1 } -| ExprStmt ';' { $1 } -| FunctionCall ';' { $1 } -| break ';' { Break } -| goto ID_CONST ';' { Goto $2 } -| continue ';' { Continue } -| return ';' { Return Nothing } -| return Expr ';' { Return (Just $2) } -| switch '(' Expr ')' CompoundStmt { Switch $3 $5 } -| Comment { $1 } +: PreprocIfdef(Stmts) { $1 } +| PreprocIf(Stmts) { $1 } +| PreprocDefine Stmts PreprocUndef { PreprocScopedDefine $1 $2 $3 } +| LabelStmt { $1 } +| DeclStmt { $1 } +| CompoundStmt { CompoundStmt $1 } +| IfStmt { $1 } +| ForStmt { $1 } +| WhileStmt { $1 } +| DoWhileStmt { $1 } +| AssignExpr ';' { $1 } +| ExprStmt ';' { $1 } +| FunctionCall ';' { $1 } +| break ';' { Break } +| goto ID_CONST ';' { Goto $2 } +| continue ';' { Continue } +| return ';' { Return Nothing } +| return Expr ';' { Return (Just $2) } +| switch '(' Expr ')' CompoundStmt { SwitchStmt $3 $5 } +| Comment { $1 } IfStmt :: { StringNode } IfStmt -: if '(' Expr ')' CompoundStmt { IfStmt $3 $5 Nothing } -| if '(' Expr ')' CompoundStmt else IfStmt { IfStmt $3 $5 (Just $7) } -| if '(' Expr ')' CompoundStmt else CompoundStmt { IfStmt $3 $5 (Just (CompoundStmt $7)) } +: if '(' Expr ')' CompoundStmt { IfStmt $3 $5 Nothing } +| if '(' Expr ')' CompoundStmt else IfStmt { IfStmt $3 $5 (Just $7) } +| if '(' Expr ')' CompoundStmt else CompoundStmt { IfStmt $3 $5 (Just (CompoundStmt $7)) } ForStmt :: { StringNode } ForStmt -: for '(' ForInit Opt(Expr) ';' Opt(ForNext) ')' CompoundStmt { ForStmt $3 $4 $6 $8 } +: for '(' ForInit Expr ';' ForNext ')' CompoundStmt { ForStmt $3 $4 $6 $8 } -ForInit :: { Maybe (StringNode) } +ForInit :: { StringNode } ForInit -: ';' { Nothing } -| AssignExpr ';' { Just $1 } -| SingleVarDecl { Just $1 } +: AssignExpr ';' { $1 } +| VarDecl { $1 } ForNext :: { StringNode } ForNext -: ExprStmt { $1 } -| AssignExpr { $1 } - -Opt(x) -: { Nothing } -| x { Just $1 } +: ExprStmt { $1 } +| AssignExpr { $1 } WhileStmt :: { StringNode } WhileStmt -: while '(' Expr ')' CompoundStmt { WhileStmt $3 $5 } +: while '(' Expr ')' CompoundStmt { WhileStmt $3 $5 } DoWhileStmt :: { StringNode } DoWhileStmt -: do CompoundStmt while '(' Expr ')' ';' { DoWhileStmt $2 $5 } +: do CompoundStmt while '(' Expr ')' ';' { DoWhileStmt $2 $5 } LabelStmt :: { StringNode } LabelStmt -: case Expr ':' Stmt { Case $2 $4 } -| default ':' Stmt { Default $3 } -| ID_CONST ':' Stmt { Label $1 $3 } +: case Expr ':' AfterLabelStmt { Case $2 $4 } +| default ':' AfterLabelStmt { Default $3 } +| ID_CONST ':' Stmt { Label $1 $3 } +AfterLabelStmt :: { StringNode } +AfterLabelStmt +: CompoundStmt { CompoundStmt $1 } +| LabelStmt { $1 } +| return Expr ';' { Return (Just $2) } + DeclStmt :: { StringNode } DeclStmt -: VarDecl { $1 } -| VLA '(' Type ',' IdVar ',' Expr ')' ';' { VLA $3 $5 $7 } - -SingleVarDecl :: { StringNode } -SingleVarDecl -: QualType Declarator ';' { VarDecl $1 [$2] } +: VarDecl { $1 } +| VLA '(' QualType ',' IdVar ',' Expr ')' ';' { VLA $3 $5 $7 } VarDecl :: { StringNode } VarDecl -: QualType Declarators ';' { VarDecl $1 (reverse $2) } - -Declarators :: { [StringNode] } -Declarators -: Declarator { [$1] } -| Declarators ',' Declarator { $3 : $1 } +: QualType Declarator ';' { VarDecl $1 $2 } Declarator :: { StringNode } Declarator -: DeclSpec '=' InitialiserExpr { Declarator $1 (Just $3) } -| DeclSpec { Declarator $1 Nothing } +: DeclSpec '=' InitialiserExpr { Declarator $1 (Just $3) } +| DeclSpec { Declarator $1 Nothing } InitialiserExpr :: { StringNode } InitialiserExpr -: InitialiserList { InitialiserList $1 } -| Expr { $1 } +: InitialiserList { InitialiserList $1 } +| Expr { $1 } DeclSpec :: { StringNode } DeclSpec -: IdVar { DeclSpecVar $1 } -| DeclSpec '[' ']' { DeclSpecArray $1 Nothing } -| DeclSpec '[' Expr ']' { DeclSpecArray $1 (Just $3) } +: IdVar { DeclSpecVar $1 } +| DeclSpec '[' ']' { DeclSpecArray $1 Nothing } +| DeclSpec '[' Expr ']' { DeclSpecArray $1 (Just $3) } IdVar :: { Lexeme String } IdVar -: ID_VAR { $1 } -| default { $1 } -| 'error' { $1 } +: ID_VAR { $1 } +| default { $1 } +| 'error' { $1 } InitialiserList :: { [StringNode] } InitialiserList -: '{' Initialisers '}' { reverse $2 } -| '{' Initialisers ',' '}' { reverse $2 } +: '{' Initialisers '}' { reverse $2 } +| '{' Initialisers ',' '}' { reverse $2 } Initialisers :: { [StringNode] } Initialisers -: Initialiser { [$1] } -| Initialisers ',' Initialiser { $3 : $1 } +: Initialiser { [$1] } +| Initialisers ',' Initialiser { $3 : $1 } Initialiser :: { StringNode } Initialiser -: Expr { $1 } -| InitialiserList { InitialiserList $1 } +: Expr { $1 } +| InitialiserList { InitialiserList $1 } CompoundStmt :: { [StringNode] } CompoundStmt -: '{' Stmts '}' { $2 } +: '{' Stmts '}' { reverse $2 } +-- Expressions that are safe for use as macro body without () around it.. +PreprocSafeExpr(x) +: LiteralExpr { $1 } +| '(' x ')' { ParenExpr $2 } +| '(' QualType ')' x %prec CAST { CastExpr $2 $4 } +| sizeof '(' x ')' { SizeofExpr $3 } +| sizeof '(' QualType ')' { SizeofType $3 } + +ConstExpr :: { StringNode } +ConstExpr +: PureExpr(ConstExpr) { $1 } + PureExpr(x) -: x '!=' x { BinaryExpr $1 BopNe $3 } -| x '==' x { BinaryExpr $1 BopEq $3 } -| x '||' x { BinaryExpr $1 BopOr $3 } -| x '^' x { BinaryExpr $1 BopBitXor $3 } -| x '|' x { BinaryExpr $1 BopBitOr $3 } -| x '&&' x { BinaryExpr $1 BopAnd $3 } -| x '&' x { BinaryExpr $1 BopBitAnd $3 } -| x '/' x { BinaryExpr $1 BopDiv $3 } -| x '*' x { BinaryExpr $1 BopMul $3 } -| x '%' x { BinaryExpr $1 BopMod $3 } -| x '+' x { BinaryExpr $1 BopPlus $3 } -| x '-' x { BinaryExpr $1 BopMinus $3 } -| x '<' x { BinaryExpr $1 BopLt $3 } -| x '<=' x { BinaryExpr $1 BopLe $3 } -| x '<<' x { BinaryExpr $1 BopLsh $3 } -| x '>' x { BinaryExpr $1 BopGt $3 } -| x '>=' x { BinaryExpr $1 BopGe $3 } -| x '>>' x { BinaryExpr $1 BopRsh $3 } -| x '?' x ':' x { TernaryExpr $1 $3 $5 } -| '(' x ')' { ParenExpr $2 } -| '!' x { UnaryExpr UopNot $2 } -| '~' x { UnaryExpr UopNeg $2 } -| '-' x %prec NEG { UnaryExpr UopMinus $2 } -| '&' x %prec ADDRESS { UnaryExpr UopAddress $2 } -| '(' QualType ')' x %prec CAST { CastExpr $2 $4 } -| sizeof '(' x ')' { SizeofExpr $3 } -| sizeof '(' Type ')' { SizeofExpr $3 } +: PreprocSafeExpr(x) { $1 } +| x '!=' x { BinaryExpr $1 BopNe $3 } +| x '==' x { BinaryExpr $1 BopEq $3 } +| x '||' x { BinaryExpr $1 BopOr $3 } +| x '^' x { BinaryExpr $1 BopBitXor $3 } +| x '|' x { BinaryExpr $1 BopBitOr $3 } +| x '&&' x { BinaryExpr $1 BopAnd $3 } +| x '&' x { BinaryExpr $1 BopBitAnd $3 } +| x '/' x { BinaryExpr $1 BopDiv $3 } +| x '*' x { BinaryExpr $1 BopMul $3 } +| x '%' x { BinaryExpr $1 BopMod $3 } +| x '+' x { BinaryExpr $1 BopPlus $3 } +| x '-' x { BinaryExpr $1 BopMinus $3 } +| x '<' x { BinaryExpr $1 BopLt $3 } +| x '<=' x { BinaryExpr $1 BopLe $3 } +| x '<<' x { BinaryExpr $1 BopLsh $3 } +| x '>' x { BinaryExpr $1 BopGt $3 } +| x '>=' x { BinaryExpr $1 BopGe $3 } +| x '>>' x { BinaryExpr $1 BopRsh $3 } +| x '?' x ':' x { TernaryExpr $1 $3 $5 } +| '!' x { UnaryExpr UopNot $2 } +| '~' x { UnaryExpr UopNeg $2 } +| '-' x %prec NEG { UnaryExpr UopMinus $2 } +| '&' x %prec ADDRESS { UnaryExpr UopAddress $2 } LiteralExpr :: { StringNode } LiteralExpr -: LIT_CHAR { LiteralExpr Char $1 } -| LIT_INTEGER { LiteralExpr Int $1 } -| LIT_FALSE { LiteralExpr Bool $1 } -| LIT_TRUE { LiteralExpr Bool $1 } -| LIT_STRING { LiteralExpr String $1 } -| ID_CONST { LiteralExpr ConstId $1 } +: StringLiteralExpr { $1 } +| LIT_CHAR { LiteralExpr Char $1 } +| LIT_INTEGER { LiteralExpr Int $1 } +| LIT_FALSE { LiteralExpr Bool $1 } +| LIT_TRUE { LiteralExpr Bool $1 } +| ID_CONST { LiteralExpr ConstId $1 } +StringLiteralExpr :: { StringNode } +StringLiteralExpr +: LIT_STRING { LiteralExpr String $1 } +| StringLiteralExpr LIT_STRING { $1 } + +LhsExpr :: { StringNode } +LhsExpr +: IdVar { VarExpr $1 } +| '*' LhsExpr %prec DEREF { UnaryExpr UopDeref $2 } +| LhsExpr '.' IdVar { MemberAccess $1 $3 } +| LhsExpr '->' IdVar { PointerAccess $1 $3 } +| LhsExpr '[' Expr ']' { ArrayAccess $1 $3 } + Expr :: { StringNode } Expr -: LhsExpr { $1 } -| ExprStmt { $1 } -| LiteralExpr { $1 } -| FunctionCall { $1 } -| PureExpr(Expr) { $1 } +: LhsExpr { $1 } +| ExprStmt { $1 } +| FunctionCall { $1 } +| PureExpr(Expr) { $1 } AssignExpr :: { StringNode } AssignExpr -: LhsExpr AssignOperator Expr { AssignExpr $1 $2 $3 } +: LhsExpr AssignOperator Expr { AssignExpr $1 $2 $3 } AssignOperator :: { AssignOp } AssignOperator -: '=' { AopEq } -| '*=' { AopMul } -| '/=' { AopDiv } -| '+=' { AopPlus } -| '-=' { AopMinus } -| '&=' { AopBitAnd } -| '|=' { AopBitOr } -| '^=' { AopBitXor } -| '%=' { AopMod } -| '<<=' { AopLsh } -| '>>=' { AopRsh } +: '=' { AopEq } +| '*=' { AopMul } +| '/=' { AopDiv } +| '+=' { AopPlus } +| '-=' { AopMinus } +| '&=' { AopBitAnd } +| '|=' { AopBitOr } +| '^=' { AopBitXor } +| '%=' { AopMod } +| '<<=' { AopLsh } +| '>>=' { AopRsh } ExprStmt :: { StringNode } ExprStmt -: '++' Expr { UnaryExpr UopIncr $2 } -| '--' Expr { UnaryExpr UopDecr $2 } - -LhsExpr :: { StringNode } -LhsExpr -: IdVar { VarExpr $1 } -| '*' LhsExpr %prec DEREF { UnaryExpr UopDeref $2 } -| LhsExpr '.' IdVar { MemberAccess $1 $3 } -| LhsExpr '->' IdVar { PointerAccess $1 $3 } -| LhsExpr '[' Expr ']' { ArrayAccess $1 $3 } +: '++' Expr { UnaryExpr UopIncr $2 } +| '--' Expr { UnaryExpr UopDecr $2 } FunctionCall :: { StringNode } FunctionCall -: Expr ArgList { FunctionCall $1 $2 } +: Expr ArgList { FunctionCall $1 $2 } ArgList :: { [StringNode] } ArgList -: '(' ')' { [] } -| '(' Args ')' { reverse $2 } +: '(' ')' { [] } +| '(' Args ')' { reverse $2 } Args :: { [StringNode] } Args -: Arg { [$1] } -| Args ',' Arg { $3 : $1 } +: Arg { [$1] } +| Args ',' Arg { $3 : $1 } Arg :: { StringNode } Arg -: Expr { $1 } -| Comment Expr { CommentExpr $1 $2 } +: Expr { $1 } +| Comment Expr { CommentExpr $1 $2 } EnumDecl :: { StringNode } EnumDecl -: enum class ID_SUE_TYPE EnumeratorList { EnumClass $3 $4 } -| enum ID_SUE_TYPE EnumeratorList { EnumConsts (Just $2) $3 } -| enum EnumeratorList ';' { EnumConsts Nothing $2 } -| typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';' { EnumDecl $3 $4 $5 } -| bitmask ID_SUE_TYPE EnumeratorList { EnumDecl $2 $3 $2 } +: enum class ID_SUE_TYPE EnumeratorList { EnumClass $3 $4 } +| enum ID_SUE_TYPE EnumeratorList { EnumConsts (Just $2) $3 } +| enum EnumeratorList ';' { EnumConsts Nothing $2 } +| typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';' { EnumDecl $3 $4 $5 } +| bitmask ID_SUE_TYPE EnumeratorList { EnumDecl $2 $3 $2 } EnumeratorList :: { [StringNode] } EnumeratorList -: '{' Enumerators '}' { $2 } +: '{' Enumerators '}' { reverse $2 } Enumerators :: { [StringNode] } Enumerators -: Enumerator { [$1] } -| Enumerators Enumerator { $2 : $1 } +: Commented(Enumerator) { [$1] } +| Enumerators Commented(Enumerator) { $2 : $1 } +Commented(x) +: x { $1 } +| DocComment x { Commented $1 $2 } + Enumerator :: { StringNode } Enumerator -: EnumeratorName ',' { Enumerator $1 Nothing } -| EnumeratorName '=' ConstExpr ',' { Enumerator $1 (Just $3) } -| namespace ID_CONST '{' Enumerators '}' { Namespace Global $2 $4 } -| Comment { $1 } +: EnumeratorName ',' { Enumerator $1 Nothing } +| EnumeratorName '=' ConstExpr ',' { Enumerator $1 (Just $3) } +| namespace ID_CONST '{' Enumerators '}' { Namespace Global $2 $4 } +| Comment { $1 } EnumeratorName :: { Lexeme String } EnumeratorName -: ID_CONST { $1 } -| ID_SUE_TYPE { $1 } +: ID_CONST { $1 } +| ID_SUE_TYPE { $1 } AggregateDecl :: { StringNode } AggregateDecl -: AggregateType ';' { $1 } -| class ID_SUE_TYPE TypeParams ';' { ClassForward $2 $3 } -| typedef AggregateType ID_SUE_TYPE ';' { Typedef $2 $3 } +: AggregateType ';' { $1 } +| class ID_SUE_TYPE TypeParams ';' { ClassForward $2 $3 } +| typedef AggregateType ID_SUE_TYPE ';' { Typedef $2 $3 } AggregateType :: { StringNode } AggregateType -: struct ID_SUE_TYPE '{' MemberDecls '}' { Struct $2 $4 } -| struct this '{' MemberDecls '}' { Struct $2 $4 } -| union ID_SUE_TYPE '{' MemberDecls '}' { Union $2 $4 } +: struct ID_SUE_TYPE '{' MemberDeclList '}' { Struct $2 $4 } +| struct this '{' MemberDeclList '}' { Struct $2 $4 } +| union ID_SUE_TYPE '{' MemberDeclList '}' { Union $2 $4 } +MemberDeclList :: { [StringNode] } +MemberDeclList +: MemberDecls { reverse $1 } + MemberDecls :: { [StringNode] } MemberDecls -: MemberDecl { [$1] } -| MemberDecls MemberDecl { $2 : $1 } +: Commented(MemberDecl) { [$1] } +| MemberDecls Commented(MemberDecl) { $2 : $1 } MemberDecl :: { StringNode } MemberDecl -: QualType DeclSpec ';' { MemberDecl $1 $2 Nothing } -| QualType DeclSpec ':' LIT_INTEGER ';' { MemberDecl $1 $2 (Just $4) } -| namespace IdVar '{' MemberDecls '}' { Namespace Global $2 $4 } -| PreprocIfdef(MemberDecls) { $1 } -| Comment { $1 } +: QualType DeclSpec ';' { MemberDecl $1 $2 Nothing } +| QualType DeclSpec ':' LIT_INTEGER ';' { MemberDecl $1 $2 (Just $4) } +| namespace IdVar '{' MemberDeclList '}' { Namespace Global $2 $4 } +| PreprocIfdef(MemberDeclList) { $1 } +| Comment { $1 } TypedefDecl :: { StringNode } TypedefDecl -: typedef QualType ID_SUE_TYPE ';' { Typedef $2 $3 } -| typedef FunctionPrototype(ID_FUNC_TYPE) ';' { TypedefFunction $2 } +: typedef QualType ID_SUE_TYPE ';' { Typedef $2 $3 } +| typedef FunctionPrototype(ID_FUNC_TYPE) ';' { TypedefFunction $2 } QualType :: { StringNode } QualType -: Type { $1 } -| const Type { TyConst $2 } - -Type :: { StringNode } -Type -: LeafType { $1 } -| Type '*' { TyPointer $1 } -| Type const { TyConst $1 } +: LeafType { $1 } +| LeafType '*' { TyPointer $1 } +| LeafType '*' '*' { TyPointer (TyPointer $1) } +| LeafType '*' const { TyConst (TyPointer $1) } +| LeafType '*' const '*' { TyPointer (TyConst (TyPointer $1)) } +| LeafType const { TyConst $1 } +| LeafType const '*' { TyPointer (TyConst $1) } +| LeafType const '*' const { TyConst (TyPointer (TyConst $1)) } +| LeafType const '*' const '*' { TyPointer (TyConst (TyPointer (TyConst $1))) } +| const LeafType { TyConst $2 } +| const LeafType '*' { TyPointer (TyConst $2) } +| const LeafType '*' const { TyConst (TyPointer (TyConst $2)) } +| const LeafType '*' const '*' { TyPointer (TyConst (TyPointer (TyConst $2))) } LeafType :: { StringNode } LeafType -: struct ID_SUE_TYPE { TyStruct $2 } -| void { TyStd $1 } -| this { TyStd $1 } -| ID_FUNC_TYPE { TyFunc $1 } -| ID_STD_TYPE { TyStd $1 } -| ID_SUE_TYPE { TyUserDefined $1 } -| ID_TYVAR { TyVar $1 } +: struct ID_SUE_TYPE { TyStruct $2 } +| void { TyStd $1 } +| this { TyStd $1 } +| ID_FUNC_TYPE { TyFunc $1 } +| ID_STD_TYPE { TyStd $1 } +| ID_SUE_TYPE { TyUserDefined $1 } +| ID_TYVAR { TyVar $1 } FunctionDecl :: { StringNode } FunctionDecl -: FunctionDeclarator { $1 Global } -| static FunctionDeclarator { $2 Static } +: FunctionDeclarator { $1 Global } +| static FunctionDeclarator { $2 Static } FunctionDeclarator :: { Scope -> StringNode } FunctionDeclarator -: FunctionPrototype(IdVar) WithError { \s -> FunctionDecl s $1 $2 } -| FunctionPrototype(IdVar) CompoundStmt { \s -> FunctionDefn s $1 $2 } -| QualType DeclSpec '{' Accessors '}' { \s -> Property $1 $2 $4 } +: FunctionPrototype(IdVar) WithError { \s -> FunctionDecl s $1 $2 } +| FunctionPrototype(IdVar) CompoundStmt { \s -> FunctionDefn s $1 $2 } +| QualType DeclSpec '{' Accessors '}' { \s -> Property $1 $2 (reverse $4) } Accessors :: { [StringNode] } Accessors -: Accessor { [$1] } -| Accessors Accessor { $2 : $1 } +: Accessor { [$1] } +| Accessors Accessor { $2 : $1 } Accessor :: { StringNode } Accessor -: IdVar FunctionParamList WithError { Accessor $1 $2 $3 } -| Comment { $1 } +: IdVar FunctionParamList WithError { Accessor $1 $2 $3 } +| Comment { $1 } WithError :: { Maybe StringNode } WithError -: ';' { Nothing } -| with 'error' EnumeratorList { Just (ErrorList $3) } -| with 'error' for IdVar ';' { Just (ErrorFor $4) } +: ';' { Nothing } +| with 'error' EnumeratorList { Just (ErrorList $3) } +| with 'error' for IdVar ';' { Just (ErrorFor $4) } FunctionPrototype(id) -: QualType id FunctionParamList { FunctionPrototype $1 $2 $3 } -| QualType id FunctionParamList const { FunctionPrototype $1 $2 $3 } +: QualType id FunctionParamList { FunctionPrototype $1 $2 $3 } +| QualType id FunctionParamList const { FunctionPrototype $1 $2 $3 } FunctionParamList :: { [StringNode] } FunctionParamList -: '(' ')' { [] } -| '(' void ')' { [TyStd $2] } -| '(' FunctionParams ')' { reverse $2 } -| '(' FunctionParams ',' '...' ')' { reverse $ Ellipsis : $2 } +: '(' ')' { [] } +| '(' void ')' { [TyStd $2] } +| '(' FunctionParams ')' { reverse $2 } +| '(' FunctionParams ',' '...' ')' { reverse $ Ellipsis : $2 } FunctionParams :: { [StringNode] } FunctionParams -: FunctionParam { [$1] } -| FunctionParams ',' FunctionParam { $3 : $1 } +: FunctionParam { [$1] } +| FunctionParams ',' FunctionParam { $3 : $1 } FunctionParam :: { StringNode } FunctionParam -: QualType DeclSpec { FunctionParam $1 $2 } +: QualType DeclSpec { FunctionParam $1 $2 } ConstDecl :: { StringNode } ConstDecl -: extern const LeafType ID_VAR ';' { ConstDecl $3 $4 } -| const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Global $2 $3 $5 } -| static const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Static $3 $4 $6 } +: extern const LeafType ID_VAR ';' { ConstDecl $3 $4 } +| const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Global $2 $3 $5 } +| static const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Static $3 $4 $6 } { -type StringNode = Node (Lexeme String) +type StringLexeme = Lexeme String +type StringNode = Node StringLexeme -parseError :: Show text => Lexeme text -> Alex a -parseError token = alexError $ "Parse error near token: " <> show token +parseError :: Show text => (Lexeme text, [String]) -> Alex a +parseError (token, options) = + alexError $ "Parse error near token: " <> show token <> "; expected one of " <> show options lexwrap :: (Lexeme String -> Alex a) -> Alex a lexwrap = (alexMonadScan >>=) diff --git a/src/Language/Cimple/Pretty.hs b/src/Language/Cimple/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/Pretty.hs @@ -0,0 +1,567 @@ +module Language.Cimple.Pretty (ppTranslationUnit) where + +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Cimple (AssignOp (..), BinaryOp (..), + CommentStyle (..), Lexeme (..), + LexemeClass (..), Node (..), + Scope (..), UnaryOp (..), + lexemeText) +import Prelude hiding ((<$>)) +import Text.Groom (groom) +import Text.PrettyPrint.ANSI.Leijen + +ppText :: Text -> Doc +ppText = text . Text.unpack + +ppLexeme :: Lexeme Text -> Doc +ppLexeme = ppText . lexemeText + +ppCommaSep :: (a -> Doc) -> [a] -> Doc +ppCommaSep go = foldr (<>) empty . List.intersperse (text ", ") . map go + +ppLineSep :: (a -> Doc) -> [a] -> Doc +ppLineSep go = foldr (<>) empty . List.intersperse linebreak . map go + +ppComment :: CommentStyle -> [Node (Lexeme Text)] -> Doc +ppComment style cs = + nest 1 (ppCommentStyle style <> ppCommentBody cs) <+> text "*/" + +ppCommentStyle :: CommentStyle -> Doc +ppCommentStyle Block = text "/***" +ppCommentStyle Doxygen = text "/**" +ppCommentStyle Regular = text "/*" + +ppCommentBody :: [Node (Lexeme Text)] -> Doc +ppCommentBody = go . map unCommentWord + where + unCommentWord (CommentWord l) = l + unCommentWord x = error $ groom x + + go (L _ LitInteger t1 : L _ PctMinus m : L _ LitInteger t2 : xs) = + space <> ppText t1 <> ppText m <> ppText t2 <> go xs + go (L _ PctMinus m : L _ LitInteger t : xs) = + space <> ppText m <> ppText t <> go xs + + go (l : L _ PctPeriod t : xs) = go [l] <> ppText t <> go xs + go (l : L _ PctComma t : xs) = go [l] <> ppText t <> go xs + go (x : xs) = ppWord x <> go xs + go [] = empty + + ppWord (L _ CmtSpdxLicense t) = space <> ppText t + ppWord (L _ CmtSpdxCopyright t) = space <> ppText t + ppWord (L _ CmtWord t) = space <> ppText t + ppWord (L _ CmtCode t) = space <> ppText t + ppWord (L _ CmtRef t) = space <> ppText t + ppWord (L _ CmtIndent _) = char '*' + ppWord (L _ PpNewline _) = linebreak + ppWord (L _ LitInteger t) = space <> ppText t + ppWord (L _ LitString t) = space <> ppText t + ppWord (L _ PctEMark t) = space <> ppText t + ppWord (L _ PctPlus t) = space <> ppText t + ppWord (L _ PctEq t) = space <> ppText t + ppWord (L _ PctMinus t) = space <> ppText t + ppWord (L _ PctPeriod t) = space <> ppText t + ppWord (L _ PctLParen t) = space <> ppText t + ppWord (L _ PctRParen t) = space <> ppText t + ppWord (L _ PctSemicolon t) = space <> ppText t + ppWord (L _ PctColon t) = space <> ppText t + ppWord (L _ PctQMark t) = space <> ppText t + ppWord (L _ PctSlash t) = space <> ppText t + ppWord (L _ PctGreater t) = space <> ppText t + ppWord (L _ PctLess t) = space <> ppText t + ppWord (L _ PctComma t) = space <> ppText t + ppWord x = error $ groom x + +ppScope :: Scope -> Doc +ppScope Global = empty +ppScope Static = text "static " + +ppType :: Node (Lexeme Text) -> Doc +ppType (TyPointer ty) = ppType ty <> char '*' +ppType (TyConst ty) = ppType ty <+> text "const" +ppType (TyUserDefined l ) = ppLexeme l +ppType (TyStd l ) = ppLexeme l +ppType (TyFunc l ) = ppLexeme l +ppType (TyStruct l ) = text "struct" <+> ppLexeme l +ppType (TyVar l ) = ppLexeme l +ppType x = error . groom $ x + +ppAssignOp :: AssignOp -> Doc +ppAssignOp op = case op of + AopEq -> text "=" + AopMul -> text "*=" + AopDiv -> text "/=" + AopPlus -> text "+=" + AopMinus -> text "-=" + AopBitAnd -> text "&=" + AopBitOr -> text "|=" + AopBitXor -> text "^=" + AopMod -> text "%=" + AopLsh -> text ">>=" + AopRsh -> text "<<=" + +ppBinaryOp :: BinaryOp -> Doc +ppBinaryOp op = case op of + BopNe -> text "!=" + BopEq -> text "==" + BopOr -> text "||" + BopBitXor -> char '^' + BopBitOr -> char '|' + BopAnd -> text "&&" + BopBitAnd -> char '&' + BopDiv -> char '/' + BopMul -> char '*' + BopMod -> char '%' + BopPlus -> char '+' + BopMinus -> char '-' + BopLt -> char '<' + BopLe -> text "<=" + BopLsh -> text "<<" + BopGt -> char '>' + BopGe -> text ">=" + BopRsh -> text ">>" + +ppUnaryOp :: UnaryOp -> Doc +ppUnaryOp op = case op of + UopNot -> char '!' + UopNeg -> char '~' + UopMinus -> char '-' + UopAddress -> char '&' + UopDeref -> char '*' + UopIncr -> text "++" + UopDecr -> text "--" + +ppInitialiserList :: [Node (Lexeme Text)] -> Doc +ppInitialiserList l = char '{' <+> ppCommaSep ppExpr l <+> char '}' + +ppDeclSpec :: Node (Lexeme Text) -> Doc +ppDeclSpec (DeclSpecVar var ) = ppLexeme var +ppDeclSpec (DeclSpecArray dspec dim) = ppDeclSpec dspec <> ppDim dim + where + ppDim Nothing = text "[]" + ppDim (Just x) = char '[' <> ppExpr x <> char ']' +ppDeclSpec x = error $ groom x + +ppDeclarator :: Node (Lexeme Text) -> Doc +ppDeclarator (Declarator dspec Nothing) = + ppDeclSpec dspec +ppDeclarator (Declarator dspec (Just initr)) = + ppDeclSpec dspec <+> char '=' <+> ppExpr initr +ppDeclarator x = error $ groom x + +ppFunctionParamList :: [Node (Lexeme Text)] -> Doc +ppFunctionParamList xs = char '(' <> ppCommaSep go xs <> char ')' + where + go (TyStd l@(L _ KwVoid _)) = ppLexeme l + go (FunctionParam ty dspec) = ppType ty <+> ppDeclSpec dspec + go Ellipsis = text "..." + go x = error $ groom x + +ppFunctionPrototype + :: Node (Lexeme Text) + -> Lexeme Text + -> [Node (Lexeme Text)] + -> Doc +ppFunctionPrototype ty name params = + ppType ty <+> ppLexeme name <> ppFunctionParamList params + +ppWithError :: Maybe (Node (Lexeme Text)) -> Doc +ppWithError Nothing = char ';' +ppWithError (Just (ErrorFor name)) = + text " with error for" <+> ppLexeme name <> char ';' +ppWithError (Just (ErrorList errs)) = + nest 2 ( + text " with error" <+> char '{' <$> + ppEnumeratorList errs + ) <$> char '}' +ppWithError x = error $ groom x + +ppFunctionCall :: Node (Lexeme Text) -> [Node (Lexeme Text)] -> Doc +ppFunctionCall callee args = + ppExpr callee <> char '(' <> ppCommaSep ppExpr args <> char ')' + +ppMacroBody :: Node (Lexeme Text) -> Doc +ppMacroBody (MacroBodyFunCall e@FunctionCall{}) = ppExpr e +ppMacroBody (MacroBodyStmt body) = + nest 2 ( + text "do {" <$> + ppStmtList body + ) <$> text "} while (0)" +ppMacroBody x = error $ groom x + +ppMacroParam :: Node (Lexeme Text) -> Doc +ppMacroParam (MacroParam l) = ppLexeme l +ppMacroParam Ellipsis = text "..." +ppMacroParam x = error $ groom x + +ppMacroParamList :: [Node (Lexeme Text)] -> Doc +ppMacroParamList xs = char '(' <> ppCommaSep ppMacroParam xs <> char ')' + +ppNamespace :: ([a] -> Doc) -> Scope -> Lexeme Text -> [a] -> Doc +ppNamespace pp scope name members = + nest 2 ( + ppScope scope <> + text "namespace" <+> ppLexeme name <+> char '{' <$> + pp members + ) <$> char '}' + +ppEnumerator :: Node (Lexeme Text) -> Doc +ppEnumerator (Comment style _ cs _ ) = ppComment style cs +ppEnumerator (Enumerator name Nothing) = ppLexeme name <> char ',' +ppEnumerator (Enumerator name (Just value)) = + ppLexeme name <+> char '=' <+> ppExpr value <> char ',' +ppEnumerator (Namespace scope name members) = + ppNamespace ppEnumeratorList scope name members +ppEnumerator x = error $ groom x + +ppEnumeratorList :: [Node (Lexeme Text)] -> Doc +ppEnumeratorList = ppLineSep ppEnumerator + +ppMemberDecl :: Node (Lexeme Text) -> Doc +ppMemberDecl = ppDecl + +ppMemberDeclList :: [Node (Lexeme Text)] -> Doc +ppMemberDeclList = ppLineSep ppMemberDecl + +ppAccessor :: Node (Lexeme Text) -> Doc +ppAccessor (Comment style _ cs _) = ppComment style cs +ppAccessor (Accessor name params errs) = + ppLexeme name <> ppFunctionParamList params <> ppWithError errs +ppAccessor x = error $ groom x + +ppAccessorList :: [Node (Lexeme Text)] -> Doc +ppAccessorList = ppLineSep ppAccessor + +ppEventType :: Node (Lexeme Text) -> Doc +ppEventType (Commented (Comment style _ cs _) ty) = + ppComment style cs <$> ppEventType ty +ppEventType (EventParams params) = + text "typedef void" <> ppFunctionParamList params +ppEventType x = error $ groom x + +ppTypeParams :: [Node (Lexeme Text)] -> Doc +ppTypeParams [] = empty +ppTypeParams xs = char '<' <> ppCommaSep pp xs <> char '>' + where + pp (TyVar x) = ppLexeme x + pp x = error $ groom x + +ppCompoundStmt :: [Node (Lexeme Text)] -> Doc +ppCompoundStmt body = + nest 2 ( + char '{' <$> + ppStmtList body + ) <$> char '}' + +ppStmtList :: [Node (Lexeme Text)] -> Doc +ppStmtList = ppLineSep ppDecl + +ppIfStmt + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] + -> Maybe (Node (Lexeme Text)) + -> Doc +ppIfStmt cond t Nothing = + nest 2 ( + text "if (" <> ppExpr cond <> text ") {" <$> + ppStmtList t + ) <$> char '}' +ppIfStmt cond t (Just e) = + nest 2 ( + text "if (" <> ppExpr cond <> text ") {" <$> + ppStmtList t + ) <$> nest 2 (char '}' <> text " else " <> ppDecl e) + +ppForStmt + :: Node (Lexeme Text) + -> Node (Lexeme Text) + -> Node (Lexeme Text) + -> [Node (Lexeme Text)] + -> Doc +ppForStmt i c n body = + nest 2 ( + text "for (" + <> ppDecl i + <+> ppExpr c <> char ';' + <+> ppExpr n + <> text ") {" <$> + ppStmtList body + ) <$> char '}' + +ppWhileStmt + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] + -> Doc +ppWhileStmt c body = + nest 2 ( + text "while (" + <> ppExpr c + <> text ") {" <$> + ppStmtList body + ) <$> char '}' + +ppDoWhileStmt + :: [Node (Lexeme Text)] + -> Node (Lexeme Text) + -> Doc +ppDoWhileStmt body c = + nest 2 ( + text "do (" + <> text ") {" <$> + ppStmtList body + ) <$> text "} while (" <> ppExpr c <> char ')' + +ppSwitchStmt + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] + -> Doc +ppSwitchStmt c body = + nest 2 ( + text "switch (" + <> ppExpr c + <> text ") {" <$> + ppStmtList body + ) <$> char '}' + +ppExpr :: Node (Lexeme Text) -> Doc +ppExpr expr = case expr of + -- Expressions + VarExpr var -> ppLexeme var + LiteralExpr _ l -> ppLexeme l + SizeofExpr arg -> text "sizeof(" <> ppExpr arg <> char ')' + SizeofType arg -> text "sizeof(" <> ppType arg <> char ')' + BinaryExpr l o r -> ppExpr l <+> ppBinaryOp o <+> ppExpr r + AssignExpr l o r -> ppExpr l <+> ppAssignOp o <+> ppExpr r + TernaryExpr c t e -> ppTernaryExpr c t e + UnaryExpr o e -> ppUnaryOp o <> ppExpr e + ParenExpr e -> char '(' <> ppExpr e <> char ')' + FunctionCall c a -> ppFunctionCall c a + ArrayAccess e i -> ppExpr e <> char '[' <> ppExpr i <> char ']' + CastExpr ty e -> char '(' <> ppType ty <> char ')' <> ppExpr e + PreprocDefined n -> text "defined(" <> ppLexeme n <> char ')' + InitialiserList l -> ppInitialiserList l + PointerAccess e m -> ppExpr e <> text "->" <> ppLexeme m + MemberAccess e m -> ppExpr e <> text "." <> ppLexeme m + CommentExpr c e -> ppCommentExpr c e + + x -> error $ groom x + +ppTernaryExpr + :: Node (Lexeme Text) -> Node (Lexeme Text) -> Node (Lexeme Text) -> Doc +ppTernaryExpr c t e = + ppExpr c <+> char '?' <+> ppExpr t <+> char ':' <+> ppExpr e + +ppCommentExpr :: Node (Lexeme Text) -> Node (Lexeme Text) -> Doc +ppCommentExpr (Comment style _ body _) e = + ppCommentStyle style <+> ppCommentBody body <+> text "*/" <+> ppExpr e +ppCommentExpr c _ = error $ groom c + +ppStmt :: Node (Lexeme Text) -> Doc +ppStmt = ppDecl + +ppDeclList :: [Node (Lexeme Text)] -> Doc +ppDeclList = ppLineSep ppDecl + +ppDecl :: Node (Lexeme Text) -> Doc +ppDecl decl = case decl of + PreprocElif cond decls (PreprocElse []) -> + text "#elif" <+> ppExpr cond <$> + ppDeclList decls <$> + text "#endif" + PreprocElif cond decls elseBranch -> + text "#elif" <+> ppExpr cond <$> + ppDeclList decls <$> + ppDeclList [elseBranch] <$> + text "#endif" + PreprocIf cond decls (PreprocElse []) -> + nest (-100) (text "#if") <+> ppExpr cond <$> + ppDeclList decls <$> + text "#endif" + PreprocIf cond decls elseBranch -> + text "#if" <+> ppExpr cond <$> + ppDeclList decls <$> + ppDeclList [elseBranch] <$> + text "#endif" + PreprocIfdef name decls (PreprocElse []) -> + indent (-2) (text "#ifndef" <+> ppLexeme name <$> + ppDeclList decls) <$> + text "#endif" + PreprocIfdef name decls elseBranch -> + text "#ifdef" <+> ppLexeme name <$> + ppDeclList decls <$> + ppDeclList [elseBranch] <$> + text "#endif" + PreprocIfndef name decls (PreprocElse []) -> + text "#ifndef" <+> ppLexeme name <$> + ppDeclList decls <$> + text "#endif" + PreprocIfndef name decls elseBranch -> + text "#ifndef" <+> ppLexeme name <$> + ppDeclList decls <$> + ppDeclList [elseBranch] <$> + text "#endif" + PreprocElse decls -> + text "#else" <$> + ppDeclList decls + + PreprocScopedDefine def stmts undef -> + ppDecl def <$> ppStmtList stmts <$> ppDecl undef + + PreprocInclude hdr -> + text "#include" <+> ppLexeme hdr + PreprocDefine name -> + text "#define" <+> ppLexeme name + PreprocDefineConst name value -> + text "#define" <+> ppLexeme name <+> ppExpr value + PreprocDefineMacro name params body -> + text "#define" <+> ppLexeme name <> ppMacroParamList params <+> ppMacroBody body + PreprocUndef name -> + text "#undef" <+> ppLexeme name + + StaticAssert cond msg -> + text "static_assert" <+> ppExpr cond <> char ',' <+> ppLexeme msg <> text ");" + + Comment style _ cs _ -> + ppComment style cs + CommentBlock cs -> + ppLexeme cs + Commented c d -> + ppDecl c <$> ppDecl d + + ClassForward name [] -> + text "class" <+> ppLexeme name <> char ';' + Class scope name tyvars decls -> + ppScope scope <> + nest 2 ( + text "class" <+> ppLexeme name <> ppTypeParams tyvars <+> char '{' <$> + ppDeclList decls + ) <$> text "};" + + EnumConsts Nothing enums -> + nest 2 ( + text "enum" <+> char '{' <$> + ppEnumeratorList enums + ) <$> text "};" + EnumConsts (Just name) enums -> + nest 2 ( + text "enum" <+> ppLexeme name <+> char '{' <$> + ppEnumeratorList enums + ) <$> text "};" + EnumClass name enums -> + nest 2 ( + text "enum class" <+> ppLexeme name <+> char '{' <$> + ppEnumeratorList enums + ) <$> text "};" + EnumDecl name enums ty -> + nest 2 ( + text "typedef enum" <+> ppLexeme name <+> char '{' <$> + ppEnumeratorList enums + ) <$> text "} " <> ppLexeme ty <> char ';' + + Namespace scope name decls -> + ppNamespace ppDeclList scope name decls + + ExternC decls -> + text "#ifndef __cplusplus" <$> + text "extern \"C\" {" <$> + text "#endif" <$> + ppDeclList decls <$> + text "#ifndef __cplusplus" <$> + text "}" <$> + text "#endif" + + Struct name members -> + nest 2 ( + text "struct" <+> ppLexeme name <+> char '{' <$> + ppMemberDeclList members + ) <$> text "};" + Typedef (Union name members) tyname -> + nest 2 ( + text "typedef union" <+> ppLexeme name <+> char '{' <$> + ppMemberDeclList members + ) <$> char '}' <+> ppLexeme tyname <> char ';' + Typedef (Struct name members) tyname -> + nest 2 ( + text "typedef struct" <+> ppLexeme name <+> char '{' <$> + ppMemberDeclList members + ) <$> char '}' <+> ppLexeme tyname <> char ';' + Typedef ty name -> + text "typedef" <+> ppType ty <+> ppLexeme name <> char ';' + TypedefFunction (FunctionPrototype ty name params) -> + text "typedef" <+> + ppFunctionPrototype ty name params <> + char ';' + + MemberDecl ty dspec Nothing -> + ppType ty <+> ppDeclSpec dspec <> char ';' + MemberDecl ty dspec (Just size) -> + ppType ty <+> ppDeclSpec dspec <+> char ':' <+> ppLexeme size <> char ';' + + FunctionDecl scope (FunctionPrototype ty name params) err -> + ppScope scope <> + ppFunctionPrototype ty name params <> + ppWithError err + FunctionDefn scope (FunctionPrototype ty name params) body -> + ppScope scope <> + ppFunctionPrototype ty name params <$> + ppCompoundStmt body + + ConstDecl ty name -> + text "extern const" <+> ppType ty <+> ppLexeme name <> char ';' + ConstDefn scope ty name value -> + ppScope scope <> + ppType ty <+> ppLexeme name <+> char '=' <+> ppExpr value <> char ';' + + Event name ty -> + nest 2 ( + text "event" <+> ppLexeme name <+> char '{' <$> + ppEventType ty + ) <$> char '}' + + Property ty dspec accessors -> + nest 2 ( + ppType ty <+> ppDeclSpec dspec <+> char '{' <$> + ppAccessorList accessors + ) <$> char '}' + + ErrorDecl name errs -> + nest 2 ( + text "error for" <+> ppLexeme name <+> char '{' <$> + ppEnumeratorList errs + ) <$> char '}' + + -- Statements + Continue -> text "continue;" + Break -> text "break;" + Return Nothing -> text "return;" + Return (Just e) -> text "return" <+> ppExpr e <> char ';' + VarDecl ty declr -> ppType ty <+> ppDeclarator declr <> char ';' + IfStmt cond t e -> ppIfStmt cond t e + ForStmt i c n body -> ppForStmt i c n body + Default s -> text "default:" <+> ppStmt s + Label l s -> ppLexeme l <> char ':' <$> ppStmt s + Goto l -> text "goto " <> ppLexeme l <> char ';' + Case e s -> text "case " <> ppExpr e <> char ':' <+> ppStmt s + WhileStmt c body -> ppWhileStmt c body + DoWhileStmt body c -> ppDoWhileStmt body c + SwitchStmt c body -> ppSwitchStmt c body + CompoundStmt body -> char '{' <$> ppStmtList body <$> char '}' + VLA ty n sz -> ppVLA ty n sz + + x -> ppExpr x <> char ';' + + +ppVLA :: Node (Lexeme Text) -> Lexeme Text -> Node (Lexeme Text) -> Doc +ppVLA ty n sz = + text "VLA(" + <> ppType ty + <> text ", " + <> ppLexeme n + <> text ", " + <> ppExpr sz + <> text ");" + +ppTranslationUnit :: [Node (Lexeme Text)] -> Doc +ppTranslationUnit decls = ppDeclList decls <> linebreak diff --git a/src/Language/Cimple/Program.hs b/src/Language/Cimple/Program.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/Program.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +module Language.Cimple.Program + ( Program + , fromList + , toList + , includeGraph + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Language.Cimple.AST (Node (..)) +import Language.Cimple.Graph (Graph) +import qualified Language.Cimple.Graph as Graph +import Language.Cimple.Lexer (Lexeme (..)) +import Language.Cimple.SemCheck.Includes (collectIncludes, + normaliseIncludes) +import Language.Cimple.TranslationUnit (TranslationUnit) + + +data Program a = Program + { progAsts :: Map FilePath [Node (Lexeme a)] + , progIncludes :: Graph () FilePath + } + + +toList :: Program a -> [TranslationUnit a] +toList = Map.toList . progAsts + + +includeGraph :: Program a -> [(FilePath, FilePath)] +includeGraph = Graph.edges . progIncludes + + +fromList :: [TranslationUnit Text] -> Either String (Program Text) +fromList tus = do + let tusWithIncludes = map normaliseIncludes tus + let progAsts = Map.fromList . map fst $ tusWithIncludes + -- Check whether all includes can be resolved. + includeEdges <- mapM (uncurry $ collectIncludes $ map fst tus) tusWithIncludes + let progIncludes = Graph.fromEdges includeEdges + return Program{..} diff --git a/src/Language/Cimple/SemCheck/Includes.hs b/src/Language/Cimple/SemCheck/Includes.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/SemCheck/Includes.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE StrictData #-} +module Language.Cimple.SemCheck.Includes + ( collectIncludes + , normaliseIncludes + ) where + +import Control.Monad.State.Lazy (State) +import qualified Control.Monad.State.Lazy as State +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Cimple.AST (Node (..)) +import Language.Cimple.Lexer (Lexeme (..)) +import Language.Cimple.Tokens (LexemeClass (..)) +import Language.Cimple.TranslationUnit (TranslationUnit) +import Language.Cimple.TraverseAst (AstActions (..), + defaultActions, traverseAst) +import System.FilePath (joinPath, splitPath, + takeDirectory) + +collectIncludes + :: [FilePath] + -> TranslationUnit Text + -> [FilePath] + -> Either String ((), FilePath, [FilePath]) +collectIncludes sources (file, _) includes = + case filter (not . (`elem` sources)) includes of + [] -> Right ((), file, includes) + missing:_ -> Left $ file <> " includes missing " <> missing + + +relativeTo :: FilePath -> FilePath -> FilePath +relativeTo "." file = file +relativeTo dir file = go (splitPath dir) (splitPath file) + where + go d ("../":f) = go (init d) f + go d f = joinPath (d ++ f) + + +normaliseIncludes :: TranslationUnit Text -> (TranslationUnit Text, [FilePath]) +normaliseIncludes (file, ast) = + ((file, ast'), includes) + where + (ast', includes) = State.runState (traverseAst (go (takeDirectory file)) ast) [] + + go :: FilePath -> AstActions (State [FilePath]) Text + go dir = defaultActions + { doNode = \node act -> + case node of + PreprocInclude (L spos LitString include) -> do + let includePath = relativeTo dir $ tread include + State.modify (includePath :) + return $ PreprocInclude (L spos LitString (tshow includePath)) + + _ -> act + } + + where + tshow = Text.pack . show + tread = read . Text.unpack diff --git a/src/Language/Cimple/Tokens.hs b/src/Language/Cimple/Tokens.hs --- a/src/Language/Cimple/Tokens.hs +++ b/src/Language/Cimple/Tokens.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} module Language.Cimple.Tokens ( LexemeClass (..) ) where @@ -33,6 +34,7 @@ | KwReturn | KwSizeof | KwStatic + | KwStaticAssert | KwStruct | KwSwitch | KwThis @@ -99,7 +101,6 @@ | PpElif | PpElse | PpEndif - | PpError | PpIf | PpIfdef | PpIfndef @@ -107,7 +108,10 @@ | PpNewline | PpUndef | CmtBlock + | CmtIndent | CmtStart + | CmtStartBlock + | CmtStartDoc | CmtSpdxCopyright | CmtSpdxLicense | CmtCode diff --git a/src/Language/Cimple/TranslationUnit.hs b/src/Language/Cimple/TranslationUnit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/TranslationUnit.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE StrictData #-} +module Language.Cimple.TranslationUnit + ( TranslationUnit + ) where + +import Language.Cimple.AST (Node) +import Language.Cimple.Lexer (Lexeme) + +type TranslationUnit a = (FilePath, [Node (Lexeme a)]) diff --git a/src/Language/Cimple/TraverseAst.hs b/src/Language/Cimple/TraverseAst.hs --- a/src/Language/Cimple/TraverseAst.hs +++ b/src/Language/Cimple/TraverseAst.hs @@ -2,6 +2,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} module Language.Cimple.TraverseAst ( TraverseAst (..) , AstActions (..) @@ -16,10 +17,11 @@ traverseAst :: Applicative f => AstActions f Text -> a -> f a data AstActions f text = AstActions - { doNodes :: [Node (Lexeme text)] -> f [Node (Lexeme text)] -> f [Node (Lexeme text)] - , doNode :: Node (Lexeme text) -> f (Node (Lexeme text)) -> f (Node (Lexeme text)) - , doLexeme :: Lexeme text -> f (Lexeme text) -> f (Lexeme text) - , doText :: text -> f text -> f text + { doNodes :: [Node (Lexeme text)] -> f [Node (Lexeme text)] -> f [Node (Lexeme text)] + , doNode :: Node (Lexeme text) -> f (Node (Lexeme text)) -> f (Node (Lexeme text)) + , doLexemes :: [Lexeme text] -> f [Lexeme text] -> f [Lexeme text] + , doLexeme :: Lexeme text -> f (Lexeme text) -> f (Lexeme text) + , doText :: text -> f text -> f text } instance TraverseAst a => TraverseAst (Maybe a) where @@ -28,10 +30,11 @@ defaultActions :: Applicative f => AstActions f lexeme defaultActions = AstActions - { doNodes = const id - , doNode = const id - , doLexeme = const id - , doText = const id + { doNodes = const id + , doNode = const id + , doLexeme = const id + , doLexemes = const id + , doText = const id } instance TraverseAst Text where @@ -48,6 +51,10 @@ recurse :: TraverseAst a => a -> f a recurse = traverseAst astActions +instance TraverseAst [Lexeme Text] where + traverseAst astActions = doLexemes astActions <*> + traverse (traverseAst astActions) + instance TraverseAst (Node (Lexeme Text)) where traverseAst :: forall f . Applicative f => AstActions f Text -> Node (Lexeme Text) -> f (Node (Lexeme Text)) @@ -70,8 +77,6 @@ PreprocElse <$> recurse decls PreprocElif cond decls elseBranch -> PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch - PreprocError msg -> - PreprocError <$> recurse msg PreprocUndef name -> PreprocUndef <$> recurse name PreprocDefined name -> @@ -84,8 +89,14 @@ MacroBodyFunCall <$> recurse expr MacroParam name -> MacroParam <$> recurse name - Comment contents -> - Comment <$> recurse contents + StaticAssert cond msg -> + StaticAssert <$> recurse cond <*> recurse msg + LicenseDecl license copyrights -> + LicenseDecl <$> recurse license <*> recurse copyrights + CopyrightDecl from to owner -> + CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner + Comment doc start contents end -> + Comment doc <$> recurse start <*> recurse contents <*> recurse end CommentBlock comment -> CommentBlock <$> recurse comment CommentWord word -> @@ -104,8 +115,8 @@ pure Continue Return value -> Return <$> recurse value - Switch value cases -> - Switch <$> recurse value <*> recurse cases + SwitchStmt value cases -> + SwitchStmt <$> recurse value <*> recurse cases IfStmt cond thenStmts elseStmt -> IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt ForStmt initStmt cond next stmts -> @@ -122,8 +133,8 @@ Label <$> recurse label <*> recurse stmt VLA ty name size -> VLA <$> recurse ty <*> recurse name <*> recurse size - VarDecl ty decls -> - VarDecl <$> recurse ty <*> recurse decls + VarDecl ty decl -> + VarDecl <$> recurse ty <*> recurse decl Declarator spec value -> Declarator <$> recurse spec <*> recurse value DeclSpecVar name -> @@ -146,6 +157,8 @@ CastExpr <$> recurse ty <*> recurse expr SizeofExpr expr -> SizeofExpr <$> recurse expr + SizeofType ty -> + SizeofType <$> recurse ty LiteralExpr ty value -> LiteralExpr ty <$> recurse value VarExpr name -> diff --git a/test/Language/Cimple/PrettySpec.hs b/test/Language/Cimple/PrettySpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Cimple/PrettySpec.hs @@ -0,0 +1,119 @@ +module Language.Cimple.PrettySpec where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import qualified Data.Text as Text +import Language.Cimple.IO (parseText) +import Language.Cimple.Pretty (ppTranslationUnit) +import Text.PrettyPrint.ANSI.Leijen (displayS, renderCompact) + +getRight :: Either String a -> a +getRight (Left err) = error err +getRight (Right ok ) = ok + +pretty :: String -> String +pretty = + show + . ppTranslationUnit + . getRight + . parseText + . Text.pack + +compact :: String -> String +compact = + flip displayS "" + . renderCompact + . ppTranslationUnit + . getRight + . parseText + . Text.pack + + +spec :: Spec +spec = do + describe "renderPretty" $ do + it "pretty-prints a simple C function" $ do + let pp = pretty "int a(void) { return 3; }" + pp `shouldBe` unlines + [ "int a(void)" + , "{" + , " return 3;" + , "}" + ] + + it "pretty-prints a typedef struct" $ do + let pp = pretty "typedef struct Foo { int32_t x; } Foo;" + pp `shouldBe` unlines + [ "typedef struct Foo {" + , " int32_t x;" + , "} Foo;" + ] + + describe "renderCompact" $ do + it "pretty-prints a simple C function" $ do + let pp = compact "int a(void) { return 3; }" + pp `shouldBe` unlines + [ "int a(void)" + , "{" + , "return 3;" + , "}" + ] + + it "pretty-prints a typedef struct" $ do + let pp = compact "typedef struct Foo { int32_t x; } Foo;" + pp `shouldBe` unlines + [ "typedef struct Foo {" + , "int32_t x;" + , "} Foo;" + ] + + it "respects newlines at end of comments" $ do + compact "/* foo bar */" `shouldBe` "/* foo bar */\n" + compact "/* foo bar\n */" `shouldBe` "/* foo bar\n */\n" + + it "respects comment styles" $ do + compact "/* foo bar */" `shouldBe` "/* foo bar */\n" + compact "/** foo bar */ int a(void);" `shouldBe` "/** foo bar */\nint a(void);\n" + compact "/*** foo bar */" `shouldBe` "/*** foo bar */\n" + compact "/**** foo bar */" `shouldBe` "/*** foo bar */\n" + + it "supports punctuation in comments" $ do + compact "/* foo.bar,baz-blep */" + `shouldBe` "/* foo. bar, baz - blep */\n" + compact "/* foo? */" `shouldBe` "/* foo ? */\n" + + it "formats number ranges and negative numbers without spacing" $ do + compact "/* 123 - 456 */" `shouldBe` "/* 123-456 */\n" + compact "/* - 3 */" `shouldBe` "/* -3 */\n" + compact "/* a-b */" `shouldBe` "/* a - b */\n" + + it "formats pointer types with east-const" $ do + compact "void foo(const int *a);" + `shouldBe` "void foo(int const* a);\n" + compact "void foo(int const *a);" + `shouldBe` "void foo(int const* a);\n" + + it "supports type-variables" $ do + compact "void foo(`a a);" `shouldBe` "void foo(`a a);\n" + compact "`a id(const `a a) { return a; }" + `shouldBe` "`a id(`a const a)\n{\nreturn a;\n}\n" + + it "formats expressions and statements" $ do + compact "void foo() { return 1+2*3/4; }" + `shouldBe` "void foo()\n{\nreturn 1 + 2 * 3 / 4;\n}\n" + compact "void foo() { a = ~b << !c; }" + `shouldBe` "void foo()\n{\na = ~b << !c;\n}\n" + compact "void foo() { int a[] = {1,2,3}; }" + `shouldBe` "void foo()\n{\nint a[] = { 1, 2, 3 };\n}\n" + + it "supports variadic functions" $ do + compact "void foo(int a, ...);" + `shouldBe` "void foo(int a, ...);\n" + compact "void foo(int a, const char *msg, ...);" + `shouldBe` "void foo(int a, char const* msg, ...);\n" + + it "supports C preprocessor directives" $ do + compact "#define XYZZY 123\n" + `shouldBe` "#define XYZZY 123\n" + compact "#include \n" + `shouldBe` "#include \n" diff --git a/test/Language/CimpleSpec.hs b/test/Language/CimpleSpec.hs --- a/test/Language/CimpleSpec.hs +++ b/test/Language/CimpleSpec.hs @@ -3,9 +3,9 @@ import Test.Hspec (Spec, describe, it, shouldBe) -import Language.Cimple (AlexPosn (..), Lexeme (..), - LexemeClass (..), LiteralType (..), - Node (..), Scope (..)) +import Language.Cimple (AlexPosn (..), CommentStyle (..), + Lexeme (..), LexemeClass (..), + LiteralType (..), Node (..), Scope (..)) import Language.Cimple.IO (parseText) @@ -13,7 +13,7 @@ spec = describe "C parsing" $ do it "should parse a simple function" $ do - ast <- parseText "int a(void) { return 3; }" + let ast = parseText "int a(void) { return 3; }" ast `shouldBe` Right [ FunctionDefn Global @@ -33,7 +33,7 @@ ] it "should parse a type declaration" $ do - ast <- parseText "typedef struct Foo { int x; } Foo;" + let ast = parseText "typedef struct Foo { int x; } Foo;" ast `shouldBe` Right [ Typedef (Struct @@ -48,7 +48,7 @@ ] it "should parse a struct with bit fields" $ do - ast <- parseText "typedef struct Foo { int x : 123; } Foo;" + let ast = parseText "typedef struct Foo { int x : 123; } Foo;" ast `shouldBe` Right [ Typedef (Struct @@ -63,6 +63,34 @@ ] it "should parse a comment" $ do - ast <- parseText "/* hello */" + let ast = parseText "/* hello */" ast `shouldBe` Right - [Comment [CommentWord (L (AlexPn 3 1 4) CmtWord "hello")]] + [ Comment Regular + (L (AlexPn 0 1 1) CmtStart "/*") + [CommentWord (L (AlexPn 3 1 4) CmtWord "hello")] + (L (AlexPn 9 1 10) CmtEnd "*/") + ] + + it "supports single declarators" $ do + let ast = parseText "int main() { int a; }" + ast `shouldBe` Right + [ FunctionDefn + Global + (FunctionPrototype + (TyStd (L (AlexPn 0 1 1) IdStdType "int")) + (L (AlexPn 4 1 5) IdVar "main") + [] + ) + [ VarDecl + (TyStd (L (AlexPn 13 1 14) IdStdType "int")) + (Declarator + (DeclSpecVar (L (AlexPn 17 1 18) IdVar "a")) + Nothing + ) + ] + ] + + it "does not support multiple declarators per declaration" $ do + let ast = parseText "int main() { int a, b; }" + ast `shouldBe` Left + "Parse error near token: L (AlexPn 18 1 19) PctComma \",\"; expected one of [\"';'\"]" diff --git a/tools/cimplefmt.hs b/tools/cimplefmt.hs new file mode 100644 --- /dev/null +++ b/tools/cimplefmt.hs @@ -0,0 +1,20 @@ +module Main (main) where + +import Language.Cimple.IO (parseFile) +import Language.Cimple.Pretty (ppTranslationUnit) +import System.Environment (getArgs) + + +processFile :: FilePath -> IO () +processFile source = do + putStrLn $ "Processing " ++ source + ast <- parseFile source + case ast of + Left err -> fail err + Right ok -> print $ ppTranslationUnit $ snd ok + + +main :: IO () +main = do + args <- getArgs + mapM_ processFile args diff --git a/tools/dump-ast.hs b/tools/dump-ast.hs --- a/tools/dump-ast.hs +++ b/tools/dump-ast.hs @@ -1,23 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Language.Cimple.IO (parseFile) -import System.Environment (getArgs) -import Text.Groom (groom) - - -processFile :: FilePath -> IO () -processFile source = do - putStrLn $ "Processing " ++ source - ast <- parseFile source - case ast of - Left err -> fail err - Right ok -> putStrLn $ groom ok +import Language.Cimple.IO (parseProgram) +import qualified Language.Cimple.Program as Program +import System.Environment (getArgs) +import Text.Groom (groom) main :: IO () main = do args <- getArgs case args of - [src] -> processFile src - _ -> fail "Usage: dump-ast " + [] -> fail "Usage: dump-ast [FILE]..." + srcs -> + parseProgram srcs + >>= getRight + >>= mapM_ (putStrLn . groom) . Program.toList + where + getRight (Left err) = fail err + getRight (Right ok) = return ok diff --git a/tools/include-graph.hs b/tools/include-graph.hs new file mode 100644 --- /dev/null +++ b/tools/include-graph.hs @@ -0,0 +1,20 @@ +module Main (main) where + +import Language.Cimple.IO (parseProgram) +import qualified Language.Cimple.Program as Program +import System.Environment (getArgs) +import Text.Groom (groom) + + +main :: IO () +main = do + args <- getArgs + case args of + [] -> fail "Usage: include-graph [FILE]..." + srcs -> + parseProgram srcs + >>= getRight + >>= mapM_ (putStrLn . groom) . Program.includeGraph + where + getRight (Left err) = fail err + getRight (Right ok) = return ok