cimple 0.0.13 → 0.0.14
raw patch · 11 files changed
+491/−424 lines, 11 filesdep +splitPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: split
API changes (from Hackage documentation)
- Language.Cimple: CommentBlock :: lexeme -> NodeF lexeme a
+ Language.Cimple: AggregateDecl :: a -> NodeF lexeme a
+ Language.Cimple: CallbackDecl :: lexeme -> lexeme -> NodeF lexeme a
+ Language.Cimple: CmtCommand :: LexemeClass
+ Language.Cimple: CmtEndDocSection :: LexemeClass
+ Language.Cimple: CmtStartDocSection :: LexemeClass
+ Language.Cimple: CommentSectionEnd :: lexeme -> NodeF lexeme a
+ Language.Cimple: ExprStmt :: a -> NodeF lexeme a
+ Language.Cimple: KwNonNull :: LexemeClass
+ Language.Cimple: KwNullable :: LexemeClass
+ Language.Cimple: NonNull :: [lexeme] -> [lexeme] -> a -> NodeF lexeme a
+ Language.Cimple.Pretty: plain :: Doc -> Doc
Files
- cimple.cabal +4/−1
- src/Language/Cimple/Ast.hs +5/−1
- src/Language/Cimple/Lexer.x +26/−1
- src/Language/Cimple/MapAst.hs +10/−2
- src/Language/Cimple/Parser.y +43/−11
- src/Language/Cimple/Pretty.hs +260/−291
- src/Language/Cimple/Tokens.hs +5/−0
- src/Language/Cimple/TraverseAst.hs +74/−88
- src/Language/Cimple/TreeParser.y +23/−13
- test/Language/Cimple/PrettySpec.hs +8/−8
- tools/cimplefmt.hs +33/−8
cimple.cabal view
@@ -1,5 +1,5 @@ name: cimple-version: 0.0.13+version: 0.0.14 synopsis: Simple C-like programming language homepage: https://toktok.github.io/ license: GPL-3@@ -57,6 +57,7 @@ , monad-parallel , mtl , recursion-schemes+ , split , text , transformers-compat @@ -69,7 +70,9 @@ main-is: cimplefmt.hs build-depends: base < 5+ , bytestring , cimple+ , text executable dump-ast default-language: Haskell2010
src/Language/Cimple/Ast.hs view
@@ -44,7 +44,7 @@ | LicenseDecl lexeme [a] | CopyrightDecl lexeme (Maybe lexeme) [lexeme] | Comment CommentStyle lexeme [lexeme] lexeme- | CommentBlock lexeme+ | CommentSectionEnd lexeme | Commented a a -- Namespace-like blocks | ExternC [a]@@ -62,6 +62,7 @@ | Case a a | Default a | Label lexeme a+ | ExprStmt a -- Variable declarations | VLA a lexeme a | VarDeclStmt a (Maybe a)@@ -89,6 +90,7 @@ | EnumConsts (Maybe lexeme) [a] | EnumDecl lexeme [a] lexeme | Enumerator lexeme (Maybe a)+ | AggregateDecl a | Typedef a lexeme | TypedefFunction a | Struct lexeme [a]@@ -104,7 +106,9 @@ | FunctionDecl Scope a | FunctionDefn Scope a a | FunctionPrototype a lexeme [a]+ | CallbackDecl lexeme lexeme | Ellipsis+ | NonNull [lexeme] [lexeme] a -- Constants | ConstDecl a lexeme | ConstDefn Scope a lexeme a
src/Language/Cimple/Lexer.x view
@@ -82,6 +82,27 @@ <0> "timespec" { mkL IdSueType } <0> "timeval" { mkL IdSueType } +-- Msgpack struct types.+<0> "msgpack_iovec" { mkL IdSueType }+<0> "msgpack_object_array" { mkL IdSueType }+<0> "msgpack_object_bin" { mkL IdSueType }+<0> "msgpack_object_ext" { mkL IdSueType }+<0> "msgpack_object_kv" { mkL IdSueType }+<0> "msgpack_object_map" { mkL IdSueType }+<0> "msgpack_object" { mkL IdSueType }+<0> "msgpack_object_str" { mkL IdSueType }+<0> "msgpack_object_type" { mkL IdSueType }+<0> "msgpack_packer" { mkL IdSueType }+<0> "msgpack_packer_write" { mkL IdFuncType }+<0> "msgpack_sbuffer" { mkL IdSueType }+<0> "msgpack_timestamp" { mkL IdSueType }+<0> "msgpack_unpacked" { mkL IdSueType }+<0> "msgpack_unpacker" { mkL IdSueType }+<0> "msgpack_unpack_return" { mkL IdSueType }+<0> "msgpack_vrefbuffer" { mkL IdSueType }+<0> "msgpack_zbuffer" { mkL IdSueType }+<0> "msgpack_zone" { mkL IdSueType }+ -- Sodium constants. <0,ppSC> "crypto_auth_"[A-Z][A-Z0-9_]* { mkL IdConst } <0,ppSC> "crypto_box_"[A-Z][A-Z0-9_]* { mkL IdConst }@@ -106,6 +127,8 @@ <0> "//!TOKSTYLE-" { start ignoreSC } <0> "/*" { mkL CmtStart `andBegin` cmtSC } <0> "/**" { mkL CmtStartDoc `andBegin` cmtSC }+<0> "/** @{" { mkL CmtStartDocSection `andBegin` cmtSC }+<0> "/** @} */" { mkL CmtEndDocSection } <0> "/**""*"+ { mkL CmtStartBlock `andBegin` cmtSC } <0,cmtSC> \"(\\.|[^\"])*\" { mkL LitString } <0> '(\\|[^'])*' { mkL LitChar }@@ -131,6 +154,8 @@ <0,ppSC> "for" { mkL KwFor } <0,ppSC> "goto" { mkL KwGoto } <0,ppSC> "if" { mkL KwIf }+<0,ppSC> "non_null" { mkL KwNonNull }+<0,ppSC> "nullable" { mkL KwNullable } <0,ppSC> "return" { mkL KwReturn } <0,ppSC> "sizeof" { mkL KwSizeof } <0,ppSC> "static" { mkL KwStatic }@@ -222,7 +247,7 @@ <cmtSC> "TODO("[^\)]+"):" { mkL CmtWord } <cmtSC> "@code" { mkL CmtCode `andBegin` codeSC } <cmtSC> "<code>" { mkL CmtCode `andBegin` codeSC }-<cmtSC> [@\\][a-z]+ { mkL CmtWord }+<cmtSC> [@\\][a-z]+ { mkL CmtCommand } <cmtSC> "*"[A-Za-z][A-Za-z0-9_']*"*" { mkL CmtWord } <cmtSC> "#"[A-Za-z][A-Za-z0-9_]* { mkL CmtRef } <cmtSC> [A-Za-z][A-Za-z0-9_']* { mkL CmtWord }
src/Language/Cimple/MapAst.hs view
@@ -140,8 +140,8 @@ Fix <$> (CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner) Comment doc start contents end -> Fix <$> (Comment doc <$> recurse start <*> recurse contents <*> recurse end)- CommentBlock comment ->- Fix <$> (CommentBlock <$> recurse comment)+ CommentSectionEnd comment ->+ Fix <$> (CommentSectionEnd <$> recurse comment) Commented comment subject -> Fix <$> (Commented <$> recurse comment <*> recurse subject) ExternC decls ->@@ -172,6 +172,8 @@ Fix <$> (Default <$> recurse stmt) Label label stmt -> Fix <$> (Label <$> recurse label <*> recurse stmt)+ ExprStmt expr ->+ Fix <$> (ExprStmt <$> recurse expr) VLA ty name size -> Fix <$> (VLA <$> recurse ty <*> recurse name <*> recurse size) VarDeclStmt decl ini ->@@ -220,6 +222,8 @@ Fix <$> (EnumDecl <$> recurse name <*> recurse members <*> recurse tyName) Enumerator name value -> Fix <$> (Enumerator <$> recurse name <*> recurse value)+ AggregateDecl struct ->+ Fix <$> (AggregateDecl <$> recurse struct) Typedef ty name -> Fix <$> (Typedef <$> recurse ty <*> recurse name) TypedefFunction ty ->@@ -248,6 +252,10 @@ Fix <$> (FunctionDefn scope <$> recurse proto <*> recurse body) FunctionPrototype ty name params -> Fix <$> (FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params)+ CallbackDecl ty name ->+ Fix <$> (CallbackDecl <$> recurse ty <*> recurse name)+ NonNull nonnull nullable f ->+ Fix <$> (NonNull <$> recurse nonnull <*> recurse nullable <*> recurse f) Ellipsis -> pure $ Fix Ellipsis ConstDecl ty name ->
src/Language/Cimple/Parser.y view
@@ -41,6 +41,8 @@ for { L _ KwFor _ } goto { L _ KwGoto _ } if { L _ KwIf _ }+ non_null { L _ KwNonNull _ }+ nullable { L _ KwNullable _ } return { L _ KwReturn _ } sizeof { L _ KwSizeof _ } static { L _ KwStatic _ }@@ -115,15 +117,17 @@ '#include' { L _ PpInclude _ } '#undef' { L _ PpUndef _ } '\n' { L _ PpNewline _ }- '/**/' { L _ CmtBlock _ } '/*' { L _ CmtStart _ } '/**' { L _ CmtStartDoc _ }+ '/** @{' { L _ CmtStartDocSection _ }+ '/** @} */' { L _ CmtEndDocSection _ } '/***' { L _ CmtStartBlock _ } ' * ' { L _ CmtIndent _ } '*/' { L _ CmtEnd _ } 'Copyright' { L _ CmtSpdxCopyright _ } 'License' { L _ CmtSpdxLicense _ } CMT_CODE { L _ CmtCode _ }+ CMT_COMMAND { L _ CmtCommand _ } CMT_WORD { L _ CmtWord _ } CMT_REF { L _ CmtRef _ } @@ -201,8 +205,9 @@ Comment : '/*' CommentTokens '*/' { Fix $ Comment Regular $1 (reverse $2) $3 } | '/**' CommentTokens '*/' { Fix $ Comment Doxygen $1 (reverse $2) $3 }+| '/** @{' CommentTokens '*/' { Fix $ Comment Block $1 (reverse $2) $3 } | '/***' CommentTokens '*/' { Fix $ Comment Block $1 (reverse $2) $3 }-| '/**/' { Fix $ CommentBlock $1 }+| '/** @} */' { Fix $ CommentSectionEnd $1 } CommentTokens :: { [StringLexeme] } CommentTokens@@ -223,6 +228,7 @@ CommentWord :: { StringLexeme } CommentWord : CMT_WORD { $1 }+| CMT_COMMAND { $1 } | CMT_REF { $1 } | CMT_CODE { $1 } | LIT_INTEGER { $1 }@@ -323,9 +329,9 @@ | ForStmt { $1 } | WhileStmt { $1 } | DoWhileStmt { $1 }-| AssignExpr ';' { $1 }-| ExprStmt ';' { $1 }-| FunctionCall ';' { $1 }+| AssignExpr ';' { Fix $ ExprStmt $1 }+| ExprStmt ';' { Fix $ ExprStmt $1 }+| FunctionCall ';' { Fix $ ExprStmt $1 } | break ';' { Fix $ Break } | goto ID_CONST ';' { Fix $ Goto $2 } | ID_CONST ':' Stmt { Fix $ Label $1 $3 }@@ -347,7 +353,7 @@ ForInit :: { StringNode } ForInit-: AssignExpr ';' { $1 }+: AssignExpr ';' { Fix $ ExprStmt $1 } | VarDeclStmt { $1 } ForNext :: { StringNode }@@ -392,6 +398,7 @@ VarDecl :: { StringNode } VarDecl : QualType ID_VAR DeclSpecArrays { Fix $ VarDecl $1 $2 $3 }+| ID_FUNC_TYPE '*' ID_VAR DeclSpecArrays { Fix $ VarDecl (Fix $ TyPointer $ Fix $ TyFunc $1) $3 $4 } DeclSpecArrays :: { [StringNode] } DeclSpecArrays@@ -570,7 +577,7 @@ AggregateDecl :: { StringNode } AggregateDecl-: AggregateType ';' { $1 }+: AggregateType ';' { Fix $ AggregateDecl $1 } | typedef AggregateType ID_SUE_TYPE ';' { Fix $ Typedef $2 $3 } AggregateType :: { StringNode }@@ -619,7 +626,6 @@ LeafType : struct ID_SUE_TYPE { Fix $ TyStruct $2 } | void { Fix $ TyStd $1 }-| ID_FUNC_TYPE { Fix $ TyFunc $1 } | ID_STD_TYPE { Fix $ TyStd $1 } | ID_SUE_TYPE { Fix $ TyUserDefined $1 } @@ -627,15 +633,37 @@ FunctionDecl : FunctionDeclarator { $1 Global } | static FunctionDeclarator { $2 Static }+| NonNull FunctionDeclarator { $1 $ $2 Global }+| NonNull static FunctionDeclarator { $1 $ $3 Static } +NonNull :: { StringNode -> StringNode }+NonNull+: non_null '(' ')' { Fix . NonNull [] [] }+| nullable '(' Ints ')' { Fix . NonNull [] $3 }+| non_null '(' Ints ')' nullable '(' Ints ')' { Fix . NonNull $3 $7 }++Ints :: { [StringLexeme] }+Ints+: IntList { reverse $1 }++IntList :: { [StringLexeme] }+IntList+: LIT_INTEGER { [$1] }+| IntList ',' LIT_INTEGER { $3 : $1 }+ FunctionDeclarator :: { Scope -> StringNode } FunctionDeclarator : FunctionPrototype(ID_VAR) ';' { \s -> Fix $ FunctionDecl s $1 } | FunctionPrototype(ID_VAR) CompoundStmt { \s -> Fix $ FunctionDefn s $1 $2 }+| CallbackDecl ';' { \s -> Fix $ FunctionDecl s $1 } +CallbackDecl :: { StringNode }+CallbackDecl+: ID_FUNC_TYPE ID_VAR { Fix $ CallbackDecl $1 $2 }+ FunctionPrototype(id) : QualType id FunctionParamList { Fix $ FunctionPrototype $1 $2 $3 }-| QualType id FunctionParamList const { Fix $ FunctionPrototype $1 $2 $3 }+| ID_FUNC_TYPE '*' id FunctionParamList { Fix $ FunctionPrototype (Fix $ TyPointer $ Fix $ TyFunc $1) $3 $4 } FunctionParamList :: { [StringNode] } FunctionParamList@@ -646,8 +674,12 @@ FunctionParams :: { [StringNode] } FunctionParams-: VarDecl { [$1] }-| FunctionParams ',' VarDecl { $3 : $1 }+: FunctionParam { [$1] }+| FunctionParams ',' FunctionParam { $3 : $1 }++FunctionParam :: { StringNode }+FunctionParam+: VarDecl { $1 } ConstDecl :: { StringNode } ConstDecl
src/Language/Cimple/Pretty.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}-module Language.Cimple.Pretty (ppTranslationUnit, showNode) where+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Language.Cimple.Pretty (plain, ppTranslationUnit, showNode) where import Data.Fix (foldFix)-import qualified Data.List as List+import qualified Data.List.Split as List import Data.Text (Text) import qualified Data.Text as Text import Language.Cimple (AssignOp (..), BinaryOp (..),@@ -12,27 +14,31 @@ NodeF (..), Scope (..), UnaryOp (..), lexemeText) import Prelude hiding ((<$>))-import Text.Groom (groom)-import Text.PrettyPrint.ANSI.Leijen hiding (semi)---- | Whether a node needs a semicolon at the end when it's a statement or--- declaration.-data NeedsSemi- = SemiNo- | SemiYes---- | Annotated Doc which is passed upwards through the fold. 'fst' is the--- accumulated pretty-printed code. 'snd' states whether the current statement--- should end in a semicolon ';'. E.g. function definitions don't, while--- function declarations do.-type ADoc = (Doc, NeedsSemi)-bare, semi :: Doc -> ADoc-bare = (, SemiNo)-semi = (, SemiYes)+import Text.PrettyPrint.ANSI.Leijen --- | Copy the 'NeedsSemi' from another 'ADoc' to a newly created doc.-cp :: ADoc -> Doc -> ADoc-cp (_, s) d = (d, s)+kwBreak = dullred $ text "break"+kwCase = dullred $ text "case"+kwConst = dullgreen $ text "const"+kwContinue = dullred $ text "continue"+kwDefault = dullred $ text "default"+kwDo = dullred $ text "do"+kwElse = dullred $ text "else"+kwEnum = dullgreen $ text "enum"+kwExtern = dullgreen $ text "extern"+kwFor = dullred $ text "for"+kwGoto = dullred $ text "goto"+kwIf = dullred $ text "if"+kwNonNull = dullgreen $ text "non_null"+kwNullable = dullgreen $ text "nullable"+kwReturn = dullred $ text "return"+kwSizeof = dullred $ text "sizeof"+kwStaticAssert = dullred $ text "static_assert"+kwStatic = dullgreen $ text "static"+kwStruct = dullgreen $ text "struct"+kwSwitch = dullred $ text "switch"+kwTypedef = dullgreen $ text "typedef"+kwUnion = dullgreen $ text "union"+kwWhile = dullred $ text "while" ppText :: Text -> Doc ppText = text . Text.unpack@@ -40,31 +46,17 @@ ppLexeme :: Lexeme Text -> Doc ppLexeme = ppText . lexemeText -ppSep :: Doc -> [ADoc] -> Doc-ppSep s = foldr (<>) empty . List.intersperse s . map fst--ppCommaSep :: [ADoc] -> Doc-ppCommaSep = ppSep (text ", ")--ppLineSep :: [ADoc] -> Doc-ppLineSep = ppSep linebreak--ppSemiSep :: [ADoc] -> Doc-ppSemiSep = ppEnd (char ';')- where- ppEnd s = foldr (<>) empty . List.intersperse linebreak . map (addEnd s)-- addEnd s (d, SemiYes) = d <> s- addEnd _ (d, SemiNo) = d+commaSep :: [Doc] -> Doc+commaSep = hsep . punctuate comma ppScope :: Scope -> Doc ppScope = \case Global -> empty- Static -> text "static "+ Static -> kwStatic <> space ppAssignOp :: AssignOp -> Doc ppAssignOp = \case- AopEq -> char '='+ AopEq -> equals AopMul -> text "*=" AopDiv -> text "/=" AopPlus -> text "+="@@ -108,347 +100,324 @@ UopDecr -> text "--" ppCommentStyle :: CommentStyle -> Doc-ppCommentStyle = \case+ppCommentStyle = dullyellow . \case Block -> text "/***" Doxygen -> text "/**" Regular -> text "/*" ppCommentBody :: [Lexeme Text] -> Doc-ppCommentBody = go+ppCommentBody = vsep . map (hsep . map ppWord) . groupLines where- 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+ groupLines = List.splitWhen $ \case+ L _ PpNewline _ -> True+ _ -> False - 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 $ "ppWord: " <> groom x+ ppWord (L _ CmtIndent _) = dullyellow $ char '*'+ ppWord (L _ CmtCommand t) = dullcyan $ ppText t+ ppWord (L _ _ t) = dullyellow $ ppText t -ppComment :: CommentStyle -> [Lexeme Text] -> Doc-ppComment style cs =- nest 1 (ppCommentStyle style <> ppCommentBody cs) <+> text "*/"+ppComment :: CommentStyle -> [Lexeme Text] -> Lexeme Text -> Doc+ppComment style cs (L l c _) =+ nest 1 $ ppCommentStyle style <+> ppCommentBody (cs ++ [L l c "*/"]) -ppInitialiserList :: [ADoc] -> Doc-ppInitialiserList l = char '{' <+> ppCommaSep l <+> char '}'+ppInitialiserList :: [Doc] -> Doc+ppInitialiserList l = lbrace <+> commaSep l <+> rbrace -ppFunctionParamList :: [ADoc] -> Doc-ppFunctionParamList xs = char '(' <> ppCommaSep xs <> char ')'+ppParamList :: [Doc] -> Doc+ppParamList = parens . commaSep ppFunctionPrototype- :: ADoc+ :: Doc -> Lexeme Text- -> [ADoc]+ -> [Doc] -> Doc ppFunctionPrototype ty name params =- fst ty <+> ppLexeme name <> ppFunctionParamList params+ ty <+> ppLexeme name <> ppParamList params -ppFunctionCall :: ADoc -> [ADoc] -> Doc+ppFunctionCall :: Doc -> [Doc] -> Doc ppFunctionCall callee args =- fst callee <> char '(' <> ppCommaSep args <> char ')'--ppMacroParamList :: [ADoc] -> Doc-ppMacroParamList xs = char '(' <> ppCommaSep xs <> char ')'+ callee <> ppParamList args ppIfStmt- :: ADoc- -> ADoc- -> Maybe ADoc+ :: Doc -> Doc+ -> Maybe Doc+ -> Doc ppIfStmt cond t Nothing =- text "if (" <> fst cond <> text ")" <+> fst t+ kwIf <+> parens cond <+> t ppIfStmt cond t (Just e) =- text "if (" <> fst cond <> text ")" <+> fst t <+> text "else" <+> fst e+ kwIf <+> parens cond <+> t <+> kwElse <+> e ppForStmt- :: ADoc- -> ADoc- -> ADoc- -> ADoc+ :: Doc -> Doc+ -> Doc+ -> Doc+ -> Doc ppForStmt i c n body =- text "for ("- <> fst i <> char ';'- <+> fst c <> char ';'- <+> fst n- <> char ')' <+>- fst body+ kwFor <+> parens (i <+> c <> semi <+> n) <+> body ppWhileStmt- :: ADoc- -> ADoc+ :: Doc -> Doc+ -> Doc ppWhileStmt c body =- text "while ("- <> fst c- <> char ')' <+>- fst body+ kwWhile <+> parens c <+> body ppDoWhileStmt- :: ADoc- -> ADoc+ :: Doc -> Doc+ -> Doc ppDoWhileStmt body c =- text "do ("- <> text ") {" <$>- fst body- <+> text "while (" <> fst c <> char ')'+ kwDo <+> body <+> kwWhile <+> parens c <> semi ppSwitchStmt- :: ADoc- -> [ADoc]+ :: Doc+ -> [Doc] -> Doc ppSwitchStmt c body = nest 2 (- text "switch ("- <> fst c- <> text ") {" <$>- ppSemiSep body- ) <$> char '}'+ kwSwitch <+> parens c <+> lbrace <$>+ vcat body+ ) <$> rbrace -ppVLA :: ADoc -> Lexeme Text -> ADoc -> Doc+ppVLA :: Doc -> Lexeme Text -> Doc -> Doc ppVLA ty n sz = text "VLA("- <> fst ty+ <> ty <> text ", " <> ppLexeme n <> text ", "- <> fst sz- <> char ')'+ <> sz+ <> text ");" -ppCompoundStmt :: [ADoc] -> Doc+ppCompoundStmt :: [Doc] -> Doc ppCompoundStmt body = nest 2 (- char '{' <$>- ppSemiSep body- ) <$> char '}'+ lbrace <$>+ ppToplevel body+ ) <$> rbrace ppTernaryExpr- :: ADoc- -> ADoc- -> ADoc+ :: Doc -> Doc+ -> Doc+ -> Doc ppTernaryExpr c t e =- fst c <+> char '?' <+> fst t <+> char ':' <+> fst e+ c <+> char '?' <+> t <+> colon <+> e -ppLicenseDecl :: Lexeme Text -> [ADoc] -> Doc+ppLicenseDecl :: Lexeme Text -> [Doc] -> Doc ppLicenseDecl l cs =- ppCommentStyle Regular <+> text "SPDX-License-Identifier: " <> ppLexeme l <$>- ppLineSep cs <$>- text " */"+ dullyellow $ ppCommentStyle Regular <+> text "SPDX-License-Identifier: " <> ppLexeme l <$>+ vcat (map dullyellow cs) <$>+ dullyellow (text " */") -ppNode :: Node (Lexeme Text) -> ADoc+ppIntList :: [Lexeme Text] -> Doc+ppIntList = parens . commaSep . map (dullred . ppLexeme)++ppNode :: Node (Lexeme Text) -> Doc ppNode = foldFix go where- go :: NodeF (Lexeme Text) ADoc -> ADoc+ go :: NodeF (Lexeme Text) Doc -> Doc go = \case- StaticAssert cond msg -> semi $- text "static_assert(" <+> fst cond <> char ',' <+> ppLexeme msg <> char ')'+ StaticAssert cond msg ->+ kwStaticAssert <> parens (cond <> comma <+> dullred (ppLexeme msg)) <> semi - LicenseDecl l cs -> bare $ ppLicenseDecl l cs- CopyrightDecl from (Just to) owner -> bare $- text " * Copyright © " <>- ppLexeme from <> char '-' <> ppLexeme to <>+ LicenseDecl l cs -> ppLicenseDecl l cs+ CopyrightDecl from (Just to) owner ->+ text " * Copyright © " <> ppLexeme from <> char '-' <> ppLexeme to <+> ppCommentBody owner- CopyrightDecl from Nothing owner -> bare $- text " * Copyright © " <>- ppLexeme from <>+ CopyrightDecl from Nothing owner ->+ text " * Copyright © " <> ppLexeme from <+> ppCommentBody owner - Comment style _ cs _ -> bare $- ppComment style cs- CommentBlock cs -> bare $- ppLexeme cs- Commented (c, _) (d, s) -> (, s) $+ Comment style _ cs e ->+ ppComment style cs e+ CommentSectionEnd cs ->+ dullyellow $ ppLexeme cs+ Commented c d -> c <$> d - VarExpr var -> semi $ ppLexeme var- LiteralExpr _ l -> semi $ ppLexeme l- SizeofExpr arg -> semi $ text "sizeof(" <> fst arg <> char ')'- SizeofType arg -> semi $ text "sizeof(" <> fst arg <> char ')'- BinaryExpr l o r -> semi $ fst l <+> ppBinaryOp o <+> fst r- AssignExpr l o r -> semi $ fst l <+> ppAssignOp o <+> fst r- TernaryExpr c t e -> semi $ ppTernaryExpr c t e- UnaryExpr o e -> semi $ ppUnaryOp o <> fst e- ParenExpr e -> semi $ char '(' <> fst e <> char ')'- FunctionCall c a -> semi $ ppFunctionCall c a- ArrayAccess e i -> semi $ fst e <> char '[' <> fst i <> char ']'- CastExpr ty e -> semi $ char '(' <> fst ty <> char ')' <> fst e- CompoundExpr ty e -> semi $ char '(' <> fst ty <> char ')' <+> char '{' <> fst e <> char '}'- PreprocDefined n -> bare $ text "defined(" <> ppLexeme n <> char ')'- InitialiserList l -> semi $ ppInitialiserList l- PointerAccess e m -> semi $ fst e <> text "->" <> ppLexeme m- MemberAccess e m -> semi $ fst e <> text "." <> ppLexeme m- CommentExpr c e -> semi $ fst c <+> fst e- Ellipsis -> semi $ text "..."+ VarExpr var -> ppLexeme var+ LiteralExpr _ l -> dullred $ ppLexeme l+ SizeofExpr arg -> kwSizeof <> parens arg+ SizeofType arg -> kwSizeof <> parens arg+ BinaryExpr l o r -> l <+> ppBinaryOp o <+> r+ AssignExpr l o r -> l <+> ppAssignOp o <+> r+ TernaryExpr c t e -> ppTernaryExpr c t e+ UnaryExpr o e -> ppUnaryOp o <> e+ ParenExpr e -> parens e+ FunctionCall c a -> ppFunctionCall c a+ ArrayAccess e i -> e <> char '[' <> i <> char ']'+ CastExpr ty e -> parens ty <> e+ CompoundExpr ty e -> parens ty <+> lbrace <> e <> rbrace+ PreprocDefined n -> text "defined(" <> ppLexeme n <> char ')'+ InitialiserList l -> ppInitialiserList l+ PointerAccess e m -> e <> text "->" <> ppLexeme m+ MemberAccess e m -> e <> text "." <> ppLexeme m+ CommentExpr c e -> c <+> e+ Ellipsis -> text "..." - VarDecl ty name arrs -> bare $ fst ty <+> ppLexeme name <> ppSep empty arrs- DeclSpecArray Nothing -> bare $ text "[]"- DeclSpecArray (Just dim) -> bare $ char '[' <> fst dim <> char ']'+ VarDecl ty name arrs -> ty <+> ppLexeme name <> hcat arrs+ DeclSpecArray Nothing -> text "[]"+ DeclSpecArray (Just dim) -> brackets dim - TyPointer ty -> bare $ fst ty <> char '*'- TyConst ty -> bare $ fst ty <+> text "const"- TyUserDefined l -> bare $ ppLexeme l- TyStd l -> bare $ ppLexeme l- TyFunc l -> bare $ ppLexeme l- TyStruct l -> bare $ text "struct" <+> ppLexeme l+ TyPointer ty -> ty <> char '*'+ TyConst ty -> ty <+> kwConst+ TyUserDefined l -> dullgreen $ ppLexeme l+ TyStd l -> dullgreen $ ppLexeme l+ TyFunc l -> dullgreen $ ppLexeme l+ TyStruct l -> kwStruct <+> dullgreen (ppLexeme l) - ExternC decls -> bare $- text "#ifndef __cplusplus" <$>+ ExternC decls ->+ dullmagenta (text "#ifdef __cplusplus") <$> text "extern \"C\" {" <$>- text "#endif" <$>- ppSemiSep decls <$>- text "#ifndef __cplusplus" <$>+ dullmagenta (text "#endif") <$>+ line <>+ ppToplevel decls <$>+ line <>+ dullmagenta (text "#ifdef __cplusplus") <$> text "}" <$>- text "#endif"+ dullmagenta (text "#endif") - MacroParam l -> bare $ ppLexeme l+ MacroParam l -> ppLexeme l MacroBodyFunCall e -> e- MacroBodyStmt body -> bare $- text "do" <+> fst body <+> text "while (0)"+ MacroBodyStmt body ->+ if False+ then kwDo <+> body <+> kwWhile <+> text "(0)"+ else text "do { nothing(); } while (0) // macros aren't supported well yet" - PreprocScopedDefine def stmts undef -> bare $- fst def <$> ppSemiSep stmts <$> fst undef+ PreprocScopedDefine def stmts undef ->+ def <$> ppToplevel stmts <$> undef - PreprocInclude hdr -> bare $- text "#include" <+> ppLexeme hdr- PreprocDefine name -> bare $- text "#define" <+> ppLexeme name- PreprocDefineConst name value -> bare $- text "#define" <+> ppLexeme name <+> fst value- PreprocDefineMacro name params body -> bare $- text "#define" <+> ppLexeme name <> ppMacroParamList params <+> fst body- PreprocUndef name -> bare $- text "#undef" <+> ppLexeme name+ PreprocInclude hdr ->+ dullmagenta $ text "#include" <+> ppLexeme hdr+ PreprocDefine name ->+ dullmagenta $ text "#define" <+> ppLexeme name+ PreprocDefineConst name value ->+ dullmagenta $ text "#define" <+> ppLexeme name <+> value+ PreprocDefineMacro name params body ->+ dullmagenta $ text "#define" <+> ppLexeme name <> ppParamList params <+> body+ PreprocUndef name ->+ dullmagenta $ text "#undef" <+> ppLexeme name - PreprocIf cond decls elseBranch -> bare $- text "#if" <+> fst cond <$>- ppSemiSep decls <>- fst elseBranch <$>- text "#endif"- PreprocIfdef name decls elseBranch -> bare $- text "#ifdef" <+> ppLexeme name <$>- ppSemiSep decls <>- fst elseBranch <$>- text "#endif"- PreprocIfndef name decls elseBranch -> bare $- text "#ifndef" <+> ppLexeme name <$>- ppSemiSep decls <>- fst elseBranch <$>- text "#endif"- PreprocElse [] -> bare empty- PreprocElse decls -> bare $+ PreprocIf cond decls elseBranch ->+ dullmagenta (text "#if" <+> cond) <$>+ ppToplevel decls <>+ elseBranch <$>+ dullmagenta (text "#endif")+ PreprocIfdef name decls elseBranch ->+ dullmagenta (text "#ifdef" <+> ppLexeme name) <$>+ ppToplevel decls <>+ elseBranch <$>+ dullmagenta (text "#endif")+ PreprocIfndef name decls elseBranch ->+ dullmagenta (text "#ifndef" <+> ppLexeme name) <$>+ ppToplevel decls <>+ elseBranch <$>+ dullmagenta (text "#endif")+ PreprocElse [] -> empty+ PreprocElse decls -> linebreak <>- text "#else" <$>- ppSemiSep decls- PreprocElif cond decls elseBranch -> bare $- text "#elif" <+> fst cond <$>- ppSemiSep decls <>- fst elseBranch <$>- text "#endif"+ dullmagenta (text "#else") <$>+ ppToplevel decls+ PreprocElif cond decls elseBranch ->+ hardline <>+ dullmagenta (text "#elif") <+> cond <$>+ ppToplevel decls <>+ elseBranch - FunctionPrototype ty name params -> bare $+ CallbackDecl ty name ->+ ppLexeme ty <+> ppLexeme name+ FunctionPrototype ty name params -> ppFunctionPrototype ty name params- FunctionDecl scope proto -> semi $- ppScope scope <> fst proto- FunctionDefn scope proto body -> bare $- ppScope scope <> fst proto <+> fst body+ FunctionDecl scope proto ->+ ppScope scope <> proto <> semi+ FunctionDefn scope proto body ->+ ppScope scope <> proto <+> body - MemberDecl decl Nothing -> semi $- fst decl- MemberDecl decl (Just size) -> semi $- fst decl <+> char ':' <+> ppLexeme size+ MemberDecl decl Nothing ->+ decl <> semi+ MemberDecl decl (Just size) ->+ decl <+> colon <+> ppLexeme size <> semi - Struct name members -> semi $+ AggregateDecl struct -> struct <> semi+ Struct name members -> nest 2 (- text "struct" <+> ppLexeme name <+> char '{' <$>- ppSemiSep members- ) <$> char '}'- Union name members -> semi $+ kwStruct <+> ppLexeme name <+> lbrace <$>+ vcat members+ ) <$> rbrace+ Union name members -> nest 2 (- text "union" <+> ppLexeme name <+> char '{' <$>- ppSemiSep members- ) <$> char '}'- Typedef ty tyname -> semi $- text "typedef" <+> fst ty <+> ppLexeme tyname- TypedefFunction proto -> semi $- text "typedef" <+> fst proto+ kwUnion <+> ppLexeme name <+> lbrace <$>+ vcat members+ ) <$> rbrace+ Typedef ty tyname ->+ kwTypedef <+> ty <+> dullgreen (ppLexeme tyname) <> semi+ TypedefFunction proto ->+ kwTypedef <+> proto <> semi - ConstDecl ty name -> semi $- text "extern const" <+> fst ty <+> ppLexeme name- ConstDefn scope ty name value -> semi $- ppScope scope <> text "const" <+>- fst ty <+> ppLexeme name <+> char '=' <+> fst value+ ConstDecl ty name ->+ kwExtern <+> kwConst <+> ty <+> ppLexeme name <> semi+ ConstDefn scope ty name value ->+ ppScope scope <> kwConst <+>+ ty <+> ppLexeme name <+> equals <+> value <> semi - Enumerator name Nothing -> bare $ ppLexeme name <> char ','- Enumerator name (Just value) -> bare $- ppLexeme name <+> char '=' <+> fst value <> char ','+ Enumerator name Nothing -> ppLexeme name <> comma+ Enumerator name (Just value) ->+ ppLexeme name <+> equals <+> value <> comma - EnumConsts Nothing enums -> semi $+ EnumConsts Nothing enums -> nest 2 (- text "enum" <+> char '{' <$>- ppLineSep enums- ) <$> char '}'- EnumConsts (Just name) enums -> semi $+ kwEnum <+> lbrace <$>+ vcat enums+ ) <$> text "};"+ EnumConsts (Just name) enums -> nest 2 (- text "enum" <+> ppLexeme name <+> char '{' <$>- ppLineSep enums- ) <$> char '}'- EnumDecl name enums ty -> semi $+ kwEnum <+> ppLexeme name <+> lbrace <$>+ vcat enums+ ) <$> text "};"+ EnumDecl name enums ty -> nest 2 (- text "typedef enum" <+> ppLexeme name <+> char '{' <$>- ppLineSep enums- ) <$> text "} " <> ppLexeme ty+ kwTypedef <+> kwEnum <+> dullgreen (ppLexeme name) <+> lbrace <$>+ vcat enums+ ) <$> rbrace <+> dullgreen (ppLexeme ty) <> semi + NonNull [] [] f ->+ kwNonNull <> text "()" <$> f+ NonNull nonnull [] f ->+ kwNonNull <> ppIntList nonnull <$> f+ NonNull [] nullable f ->+ kwNullable <> ppIntList nullable <$> f+ NonNull nonnull nullable f ->+ kwNonNull <> ppIntList nonnull <+> kwNullable <> ppIntList nullable <$> f+ -- Statements- VarDeclStmt decl Nothing -> semi $ fst decl- VarDeclStmt decl (Just initr) -> semi $ fst decl <+> char '=' <+> fst initr- Return Nothing -> semi $ text "return"- Return (Just e) -> semi $ text "return" <+> fst e- Continue -> semi $ text "continue"- Break -> semi $ text "break"- IfStmt cond t e -> bare $ ppIfStmt cond t e- ForStmt i c n body -> bare $ ppForStmt i c n body- Default s -> cp s $ text "default:" <+> fst s- Label l s -> bare $ ppLexeme l <> char ':' <$> fst s- Goto l -> semi $ text "goto " <> ppLexeme l- Case e s -> cp s $ text "case " <> fst e <> char ':' <+> fst s- WhileStmt c body -> bare $ ppWhileStmt c body- DoWhileStmt body c -> semi $ ppDoWhileStmt body c- SwitchStmt c body -> bare $ ppSwitchStmt c body- CompoundStmt body -> bare $ ppCompoundStmt body- VLA ty n sz -> semi $ ppVLA ty n sz+ VarDeclStmt decl Nothing -> decl <> semi+ VarDeclStmt decl (Just initr) -> decl <+> equals <+> initr <> semi+ Return Nothing -> kwReturn <> semi+ Return (Just e) -> kwReturn <+> e <> semi+ Continue -> kwContinue <> semi+ Break -> kwBreak <> semi+ IfStmt cond t e -> ppIfStmt cond t e+ ForStmt i c n body -> ppForStmt i c n body+ Default s -> kwDefault <> colon <+> s+ Label l s -> ppLexeme l <> colon <$> s+ ExprStmt e -> e <> semi+ Goto l -> kwGoto <+> ppLexeme l <> semi+ Case e s -> kwCase <+> e <> colon <+> s+ WhileStmt c body -> ppWhileStmt c body+ DoWhileStmt body c -> ppDoWhileStmt body c+ SwitchStmt c body -> ppSwitchStmt c body+ CompoundStmt body -> ppCompoundStmt body+ VLA ty n sz -> ppVLA ty n sz +ppToplevel :: [Doc] -> Doc+ppToplevel = vcat . punctuate line ppTranslationUnit :: [Node (Lexeme Text)] -> Doc-ppTranslationUnit decls = ppSemiSep (map ppNode decls) <> linebreak+ppTranslationUnit decls = (ppToplevel . map ppNode $ decls) <> linebreak showNode :: Node (Lexeme Text) -> Text-showNode = Text.pack . show . fst . ppNode+showNode = Text.pack . show . ppNode
src/Language/Cimple/Tokens.hs view
@@ -25,6 +25,8 @@ | KwFor | KwGoto | KwIf+ | KwNonNull+ | KwNullable | KwReturn | KwSizeof | KwStatic@@ -100,10 +102,13 @@ | PpNewline | PpUndef | CmtBlock+ | CmtCommand+ | CmtEndDocSection | CmtIndent | CmtStart | CmtStartBlock | CmtStartDoc+ | CmtStartDocSection | CmtSpdxCopyright | CmtSpdxLicense | CmtCode
src/Language/Cimple/TraverseAst.hs view
@@ -83,12 +83,10 @@ -> Node (Lexeme text) -> f () traverseFileAst actions@AstActions{..} currentFile = doNode currentFile <*> \node -> case unFix node of- PreprocInclude path -> do- _ <- recurse path- pure ()- PreprocDefine name -> do- _ <- recurse name- pure ()+ PreprocInclude path ->+ recurse path+ PreprocDefine name ->+ recurse name PreprocDefineConst name value -> do _ <- recurse name _ <- recurse value@@ -113,34 +111,28 @@ _ <- recurse thenDecls _ <- recurse elseBranch pure ()- PreprocElse decls -> do- _ <- recurse decls- pure ()+ PreprocElse decls ->+ recurse decls PreprocElif cond decls elseBranch -> do _ <- recurse cond _ <- recurse decls _ <- recurse elseBranch pure ()- PreprocUndef name -> do- _ <- recurse name- pure ()- PreprocDefined name -> do- _ <- recurse name- pure ()+ PreprocUndef name ->+ recurse name+ PreprocDefined name ->+ recurse name PreprocScopedDefine define stmts undef -> do _ <- recurse define _ <- recurse stmts _ <- recurse undef pure ()- MacroBodyStmt stmts -> do- _ <- recurse stmts- pure ()- MacroBodyFunCall expr -> do- _ <- recurse expr- pure ()- MacroParam name -> do- _ <- recurse name- pure ()+ MacroBodyStmt stmts ->+ recurse stmts+ MacroBodyFunCall expr ->+ recurse expr+ MacroParam name ->+ recurse name StaticAssert cond msg -> do _ <- recurse cond _ <- recurse msg@@ -159,29 +151,25 @@ _ <- recurse contents _ <- recurse end pure ()- CommentBlock comment -> do+ CommentSectionEnd comment -> do _ <- recurse comment pure () Commented comment subject -> do _ <- recurse comment _ <- recurse subject pure ()- ExternC decls -> do- _ <- recurse decls- pure ()- CompoundStmt stmts -> do- _ <- recurse stmts- pure ()+ ExternC decls ->+ recurse decls+ CompoundStmt stmts ->+ recurse stmts Break -> pure ()- Goto label -> do- _ <- recurse label- pure ()+ Goto label ->+ recurse label Continue -> pure ()- Return value -> do- _ <- recurse value- pure ()+ Return value ->+ recurse value SwitchStmt value cases -> do _ <- recurse value _ <- recurse cases@@ -209,13 +197,15 @@ _ <- recurse value _ <- recurse stmt pure ()- Default stmt -> do- _ <- recurse stmt- pure ()+ Default stmt ->+ recurse stmt Label label stmt -> do _ <- recurse label _ <- recurse stmt pure ()+ ExprStmt expr -> do+ _ <- recurse expr+ pure () VLA ty name size -> do _ <- recurse ty _ <- recurse name@@ -230,15 +220,12 @@ _ <- recurse name _ <- recurse arrs pure ()- DeclSpecArray size -> do- _ <- recurse size- pure ()- InitialiserList values -> do- _ <- recurse values- pure ()- UnaryExpr _op expr -> do- _ <- recurse expr- pure ()+ DeclSpecArray size ->+ recurse size+ InitialiserList values ->+ recurse values+ UnaryExpr _op expr ->+ recurse expr BinaryExpr lhs _op rhs -> do _ <- recurse lhs _ <- recurse rhs@@ -252,9 +239,8 @@ _ <- recurse lhs _ <- recurse rhs pure ()- ParenExpr expr -> do- _ <- recurse expr- pure ()+ ParenExpr expr ->+ recurse expr CastExpr ty expr -> do _ <- recurse ty _ <- recurse expr@@ -263,18 +249,14 @@ _ <- recurse ty _ <- recurse expr pure ()- SizeofExpr expr -> do- _ <- recurse expr- pure ()- SizeofType ty -> do- _ <- recurse ty- pure ()- LiteralExpr _ty value -> do- _ <- recurse value- pure ()- VarExpr name -> do- _ <- recurse name- pure ()+ SizeofExpr expr ->+ recurse expr+ SizeofType ty ->+ recurse ty+ LiteralExpr _ty value ->+ recurse value+ VarExpr name ->+ recurse name MemberAccess name field -> do _ <- recurse name _ <- recurse field@@ -308,13 +290,15 @@ _ <- recurse name _ <- recurse value pure ()+ AggregateDecl struct -> do+ _ <- recurse struct+ pure () Typedef ty name -> do _ <- recurse ty _ <- recurse name pure ()- TypedefFunction ty -> do- _ <- recurse ty- pure ()+ TypedefFunction ty ->+ recurse ty Struct name members -> do _ <- recurse name _ <- recurse members@@ -327,27 +311,20 @@ _ <- recurse decl _ <- recurse bits pure ()- TyConst ty -> do- _ <- recurse ty- pure ()- TyPointer ty -> do- _ <- recurse ty- pure ()- TyStruct name -> do- _ <- recurse name- pure ()- TyFunc name -> do- _ <- recurse name- pure ()- TyStd name -> do- _ <- recurse name- pure ()- TyUserDefined name -> do- _ <- recurse name- pure ()- FunctionDecl _scope proto -> do- _ <- recurse proto- pure ()+ TyConst ty ->+ recurse ty+ TyPointer ty ->+ recurse ty+ TyStruct name ->+ recurse name+ TyFunc name ->+ recurse name+ TyStd name ->+ recurse name+ TyUserDefined name ->+ recurse name+ FunctionDecl _scope proto ->+ recurse proto FunctionDefn _scope proto body -> do _ <- recurse proto _ <- recurse body@@ -357,7 +334,16 @@ _ <- recurse name _ <- recurse params pure ()+ CallbackDecl ty name -> do+ _ <- recurse ty+ _ <- recurse name+ pure () Ellipsis ->+ pure ()+ NonNull nonnull nullable f -> do+ _ <- recurse nonnull+ _ <- recurse nullable+ _ <- recurse f pure () ConstDecl ty name -> do _ <- recurse ty
src/Language/Cimple/TreeParser.y view
@@ -52,7 +52,7 @@ licenseDecl { Fix (LicenseDecl{}) } copyrightDecl { Fix (CopyrightDecl{}) } comment { Fix (Comment{}) }- commentBlock { Fix (CommentBlock{}) }+ commentSectionEnd { Fix (CommentSectionEnd{}) } commented { Fix (Commented{}) } -- Namespace-like blocks externC { Fix (ExternC{}) }@@ -70,6 +70,7 @@ case { Fix (Case{}) } default { Fix (Default{}) } label { Fix (Label{}) }+ exprStmt { Fix (ExprStmt{}) } -- Variable declarations vLA { Fix (VLA{}) } varDeclStmt { Fix (VarDecl{}) }@@ -97,6 +98,7 @@ enumConsts { Fix (EnumConsts{}) } enumDecl { Fix (EnumDecl{}) } enumerator { Fix (Enumerator{}) }+ aggregateDecl { Fix (AggregateDecl{}) } typedef { Fix (Typedef{}) } typedefFunction { Fix (TypedefFunction{}) } struct { Fix (Struct{}) }@@ -113,6 +115,7 @@ functionDefn { Fix (FunctionDefn{}) } functionPrototype { Fix (FunctionPrototype{}) } ellipsis { Fix (Ellipsis) }+ nonNull { Fix (NonNull{}) } -- Constants constDecl { Fix (ConstDecl{}) } constDefn { Fix (ConstDefn{}) }@@ -121,15 +124,10 @@ TranslationUnit :: { [TextNode] } TranslationUnit-: licenseDecl FileComment Header { [$1, $2, $3] }-| licenseDecl FileComment Source { $1 : $2 : $3 }-| licenseDecl Header { [$1, $2] }-| licenseDecl Source { $1 : $2 }--FileComment :: { TextNode }-FileComment-: comment { $1 }-| docComment { $1 }+: licenseDecl docComment Header { [$1, Fix $ Commented $2 $3] }+| licenseDecl docComment Source { $1 : mapHead (Fix . Commented $2)$3 }+| licenseDecl Header { [$1, $2] }+| licenseDecl Source { $1 : $2 } Header :: { TextNode } Header@@ -137,11 +135,11 @@ HeaderBody :: { [TextNode] } HeaderBody-: preprocDefine Includes Decls { $1 : reverse $2 ++ reverse $3 }+: preprocDefine Includes Decls { $1 : reverse $2 ++ $3 } Source :: { [TextNode] } Source-: Features preprocInclude Includes Decls { $1 ++ [$2] ++ reverse $3 ++ reverse $4 }+: Features preprocInclude Includes Decls { $1 ++ [$2] ++ reverse $3 ++ $4 } Features :: { [TextNode] } Features@@ -168,12 +166,17 @@ Decls :: { [TextNode] } Decls+: DeclList { reverse $1 }++DeclList :: { [TextNode] }+DeclList : { [] }-| Decls Decl { $2 : $1 }+| DeclList Decl { $2 : $1 } Decl :: { TextNode } Decl : comment { $1 }+| commentSectionEnd { $1 } | CommentableDecl { $1 } | docComment CommentableDecl { Fix $ Commented $1 $2 } @@ -181,6 +184,8 @@ CommentableDecl : functionDecl { $1 } | functionDefn { $1 }+| nonNull { $1 }+| aggregateDecl { $1 } | struct { $1 } | typedef { $1 } | constDecl { $1 }@@ -207,6 +212,11 @@ instance MonadFail TreeParser where fail = TreeParser . Left+++mapHead :: (a -> a) -> [a] -> [a]+mapHead _ [] = []+mapHead f (x:xs) = f x : xs isDefine :: [TextNode] -> Bool
test/Language/Cimple/PrettySpec.hs view
@@ -4,7 +4,7 @@ import qualified Data.Text as Text import Language.Cimple.IO (parseText)-import Language.Cimple.Pretty (ppTranslationUnit)+import Language.Cimple.Pretty (plain, ppTranslationUnit) import Text.PrettyPrint.ANSI.Leijen (displayS, renderCompact) getRight :: Either String a -> a@@ -14,6 +14,7 @@ pretty :: String -> String pretty = show+ . plain . ppTranslationUnit . getRight . parseText@@ -23,6 +24,7 @@ compact = flip displayS "" . renderCompact+ . plain . ppTranslationUnit . getRight . parseText@@ -67,22 +69,20 @@ it "respects newlines at end of comments" $ do compact "/* foo bar */" `shouldBe` "/* foo bar */\n"- compact "/* foo bar\n */" `shouldBe` "/* foo bar\n */\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 */ int a(void);" `shouldBe` "/** foo bar */\n\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"+ `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 "/* 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
tools/cimplefmt.hs view
@@ -1,20 +1,45 @@ module Main (main) where -import Language.Cimple.IO (parseFile)-import Language.Cimple.Pretty (ppTranslationUnit)+import qualified Data.ByteString as BS+import Data.List (isPrefixOf)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Language.Cimple (Lexeme, Node)+import Language.Cimple.IO (parseFile, parseText)+import Language.Cimple.Pretty (plain, ppTranslationUnit) import System.Environment (getArgs) -processFile :: FilePath -> IO ()-processFile source = do+format :: Bool -> [Node (Lexeme Text)] -> Text+format color = Text.pack . show . maybePlain . ppTranslationUnit+ where+ maybePlain = if color then id else plain+++reparseText :: Text -> IO ()+reparseText code =+ case parseText code of+ Left err -> do+ BS.putStr . Text.encodeUtf8 $ code+ fail $ "re-parsing our own pretty-printed"+ <> " output failed: " <> err+ Right _ -> return ()+++processFile :: [String] -> FilePath -> IO ()+processFile flags source = do putStrLn $ "Processing " ++ source ast <- parseFile source case ast of- Left err -> fail err- Right ok -> print $ ppTranslationUnit $ snd ok+ Left err -> fail err+ Right (_, ok) ->+ if "--no-reparse" `elem` flags+ then BS.putStr . Text.encodeUtf8 . format True $ ok+ else reparseText $ format False ok main :: IO () main = do- args <- getArgs- mapM_ processFile args+ (flags, files) <- span ("-" `isPrefixOf`) <$> getArgs+ mapM_ (processFile flags) files