cimple 0.0.15 → 0.0.16

raw patch · 17 files changed

+1018/−287 lines, 17 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• cimple.cabal +4/−2
• src/Language/Cimple/Ast.hs +58/−9
• src/Language/Cimple/CommentParser.y +240/−0
• src/Language/Cimple/DescribeAst.hs +43/−0
• src/Language/Cimple/Diagnostics.hs +4/−21
• src/Language/Cimple/Flatten.hs +8/−2
• src/Language/Cimple/IO.hs +3/−2
• src/Language/Cimple/Lexer.x +38/−21
• src/Language/Cimple/MapAst.hs +98/−8
• src/Language/Cimple/ParseResult.hs +11/−0
• src/Language/Cimple/Parser.y +129/−97
• src/Language/Cimple/Pretty.hs +146/−30
• src/Language/Cimple/Tokens.hs +8/−2
• src/Language/Cimple/TraverseAst.hs +121/−9
• src/Language/Cimple/TreeParser.y +100/−76
• test/Language/Cimple/ParserSpec.hs +1/−1
• tools/cimplefmt.hs +6/−7

@@ -1,5 +1,5 @@ name:                 cimple-version:              0.0.15+version:              0.0.16 synopsis:             Simple C-like programming language homepage:             https://toktok.github.io/ license:              GPL-3@@ -36,9 +36,12 @@   other-modules:       Language.Cimple.Annot     , Language.Cimple.Ast+    , Language.Cimple.CommentParser+    , Language.Cimple.DescribeAst     , Language.Cimple.Flatten     , Language.Cimple.Graph     , Language.Cimple.Lexer+    , Language.Cimple.ParseResult     , Language.Cimple.Parser     , Language.Cimple.SemCheck.Includes     , Language.Cimple.Tokens@@ -53,7 +56,6 @@     , containers     , data-fix     , filepath-    , groom     , monad-parallel     , mtl     , recursion-schemes

@@ -13,12 +13,14 @@     , Node, NodeF (..)     , Scope (..)     , CommentStyle (..)+    , Comment+    , CommentF (..)     ) where  import           Data.Aeson                   (FromJSON, FromJSON1, ToJSON,                                                ToJSON1) import           Data.Fix                     (Fix)-import           Data.Functor.Classes         (Eq1, Read1, Show1)+import           Data.Functor.Classes         (Eq1, Ord1, Read1, Show1) import           Data.Functor.Classes.Generic (FunctorClassesDefault (..)) import           GHC.Generics                 (Generic, Generic1) @@ -44,10 +46,15 @@     | LicenseDecl lexeme [a]     | CopyrightDecl lexeme (Maybe lexeme) [lexeme]     | Comment CommentStyle lexeme [lexeme] lexeme+    | CommentSection a [a] a     | CommentSectionEnd lexeme     | Commented a a+    | CommentInfo (Comment lexeme)     -- Namespace-like blocks     | ExternC [a]+    -- An inferred coherent block of nodes, printed without empty lines+    -- between them.+    | Group [a]     -- Statements     | CompoundStmt [a]     | Break@@ -104,6 +111,7 @@     | TyStd lexeme     | TyUserDefined lexeme     -- Functions+    | AttrPrintf lexeme lexeme a     | FunctionDecl Scope a     | FunctionDefn Scope a a     | FunctionPrototype a lexeme [a]@@ -113,14 +121,53 @@     -- Constants     | ConstDecl a lexeme     | ConstDefn Scope a lexeme a-    deriving (Show, Read, Eq, Generic, Generic1, Functor, Foldable, Traversable)-    deriving (Show1, Read1, Eq1) via FunctorClassesDefault (NodeF lexeme)+    deriving (Show, Read, Eq, Ord, Generic, Generic1, Functor, Foldable, Traversable)+    deriving (Show1, Read1, Eq1, Ord1) via FunctorClassesDefault (NodeF lexeme)  type Node lexeme = Fix (NodeF lexeme)  instance FromJSON lexeme => FromJSON1 (NodeF lexeme) instance ToJSON lexeme => ToJSON1 (NodeF lexeme) +data CommentF lexeme a+    = DocComment [a]+    | DocWord lexeme+    | DocSentence [a] lexeme+    | DocNewline++    | DocAttention [a]+    | DocBrief [a]+    | DocDeprecated [a]+    | DocExtends lexeme+    | DocImplements lexeme+    | DocParam (Maybe lexeme) lexeme [a]+    | DocReturn [a]+    | DocRetval lexeme [a]+    | DocSee lexeme [a]++    | DocPrivate++    | DocParagraph [a]+    | DocLine [a]+    | DocList [a]+    | DocULItem [a] [a]+    | DocOLItem lexeme [a]++    | DocColon lexeme+    | DocRef lexeme+    | DocP lexeme+    | DocLParen a+    | DocRParen a+    | DocAssignOp AssignOp a a+    | DocBinaryOp BinaryOp a a+    deriving (Show, Read, Eq, Ord, Generic, Generic1, Functor, Foldable, Traversable)+    deriving (Show1, Read1, Eq1, Ord1) via FunctorClassesDefault (CommentF lexeme)++type Comment lexeme = Fix (CommentF lexeme)++instance FromJSON lexeme => FromJSON1 (CommentF lexeme)+instance ToJSON lexeme => ToJSON1 (CommentF lexeme)+ data AssignOp     = AopEq     | AopMul@@ -133,7 +180,7 @@     | AopMod     | AopLsh     | AopRsh-    deriving (Show, Read, Eq, Generic)+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON AssignOp instance ToJSON AssignOp@@ -157,7 +204,7 @@     | BopGt     | BopGe     | BopRsh-    deriving (Show, Read, Eq, Generic)+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON BinaryOp instance ToJSON BinaryOp@@ -170,7 +217,7 @@     | UopDeref     | UopIncr     | UopDecr-    deriving (Show, Read, Eq, Generic)+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON UnaryOp instance ToJSON UnaryOp@@ -181,7 +228,7 @@     | Bool     | String     | ConstId-    deriving (Show, Read, Eq, Generic)+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON LiteralType instance ToJSON LiteralType@@ -189,7 +236,7 @@ data Scope     = Global     | Static-    deriving (Show, Read, Eq, Generic)+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON Scope instance ToJSON Scope@@ -197,8 +244,10 @@ data CommentStyle     = Regular     | Doxygen+    | Section     | Block-    deriving (Show, Read, Eq, Generic)+    | Ignore+    deriving (Enum, Bounded, Ord, Show, Read, Eq, Generic)  instance FromJSON CommentStyle instance ToJSON CommentStyle

@@ -0,0 +1,240 @@+{+{-# LANGUAGE OverloadedStrings #-}+module Language.Cimple.CommentParser+    ( parseComment+    ) where++import           Data.Fix                    (Fix (..))+import           Data.Text                   (Text)+import qualified Data.Text                   as Text++import           Language.Cimple.Ast         (AssignOp (..), BinaryOp (..),+                                              Comment, CommentF (..))+import           Language.Cimple.DescribeAst (describeLexeme, sloc)+import           Language.Cimple.Lexer       (Lexeme (..))+import           Language.Cimple.ParseResult (ParseResult)+import           Language.Cimple.Tokens      (LexemeClass (..))+}++%name parseComment Comment++%expect 0++%error {parseError}+%errorhandlertype explist+%monad {ParseResult}+%tokentype {Term}+%token+    '@attention'		{ L _ CmtCommand "@attention"	}+    '@brief'			{ L _ CmtCommand "@brief"	}+    '@deprecated'		{ L _ CmtCommand "@deprecated"	}+    '@extends'			{ L _ CmtCommand "@extends"	}+    '@implements'		{ L _ CmtCommand "@implements"	}+    '@param'			{ L _ CmtCommand "@param"	}+    '@private'			{ L _ CmtCommand "@private"	}+    '@ref'			{ L _ CmtCommand "@ref"		}+    '@p'			{ L _ CmtCommand "@p"		}+    '@return'			{ L _ CmtCommand "@return"	}+    '@retval'			{ L _ CmtCommand "@retval"	}+    '@see'			{ L _ CmtCommand "@see"		}++    ' '				{ L _ CmtIndent		" "	}+    'INDENT1'			{ L _ CmtIndent		"   "	}+    'INDENT2'			{ L _ CmtIndent		"    " 	}+    'INDENT3'			{ L _ CmtIndent		"     "	}++    '('				{ L _ PctLParen			_ }+    ')'				{ L _ PctRParen			_ }+    ','				{ L _ PctComma			_ }+    ':'				{ L _ PctColon			_ }+    '/'				{ L _ PctSlash			_ }+    '='				{ L _ PctEq			_ }+    '=='			{ L _ PctEqEq			_ }+    '!='			{ L _ PctEMarkEq		_ }+    '>='			{ L _ PctGreaterEq		_ }+    ';'				{ L _ PctSemicolon		_ }+    '.'				{ L _ PctPeriod			_ }+    '...'			{ L _ PctEllipsis		_ }+    '?'				{ L _ PctQMark			_ }+    '!'				{ L _ PctEMark			_ }+    '-'				{ L _ PctMinus			_ }+    '+'				{ L _ PctPlus			_ }+    '\n'			{ L _ PpNewline			_ }+    '/**'			{ L _ CmtStartDoc		_ }+    '*/'			{ L _ CmtEnd			_ }+    LIT_INTEGER			{ L _ LitInteger		_ }+    LIT_STRING			{ L _ LitString			_ }+    CMT_ATTR			{ L _ CmtAttr			_ }+    CMT_CODE			{ L _ CmtCode			_ }+    CMT_WORD			{ L _ CmtWord			_ }+    CMT_REF			{ L _ CmtRef			_ }++%right '='+%left '.' '?' ',' ';' '!'+%left '!=' '=='+%left '>='+%left '-' '+'+%left '/'+%left '(' ')'++%%++Comment :: { NonTerm }+Comment+:	'/**' '\n' Blocks '*/'					{ Fix $ DocComment $3 }+|	'/**' DocLine '*/'					{ Fix $ DocComment $2 }+|	'/**' Command(DocLine) '*/'				{ Fix $ DocComment [$2] }+|	'/**' Command(IndentedSentence) Blocks '*/'		{ Fix $ DocComment ($2 : $3) }++Blocks :: { [NonTerm] }+Blocks+:	BlockList						{ reverse $1 }++BlockList :: { [NonTerm] }+BlockList+:	Block							{ [$1] }+|	BlockList Block						{ $2 : $1 }++Block :: { NonTerm }+Block+:	'\n'							{ Fix DocNewline }+|	' ' Command(IndentedSentence)				{ $2 }+|	' ' Paragraph						{ Fix $ DocParagraph $2 }+|	' ' NumberedListItem					{ Fix $ DocList [$2] }+|	' ' BulletListItem					{ Fix $ DocList [$2] }++Paragraph :: { [NonTerm] }+Paragraph+:	Word(NonInt) Punctuation MaybeWords			{ Fix (DocSentence [$1] $2) : $3 }+|	Word(NonInt) MaybeWords					{ prepend $1 $2 }++Punctuation :: { Term }+Punctuation+:	'.'							{ $1 }+|	','							{ $1 }+|	';'							{ $1 }+|	'?'							{ $1 }++MaybeWords :: { [NonTerm] }+MaybeWords+:								{ [] }+|	IndentedSentence					{ $1 }++IndentedSentence :: { [NonTerm] }+IndentedSentence+:	DocLine '\n'						{ $1 }+|	DocLine '\n' 'INDENT1' IndentedSentence			{ $1 ++ $4 }++DocLine :: { [NonTerm] }+DocLine+:	Words							{ [Fix $ DocLine $1] }++Command(x)+:	'@attention' x						{ Fix $ DocAttention $2 }+|	'@brief' x						{ Fix $ DocBrief $2 }+|	'@param' CMT_WORD x					{ Fix $ DocParam Nothing $2 $3 }+|	'@param' CMT_ATTR CMT_WORD x				{ Fix $ DocParam (Just $2) $3 $4 }+|	'@retval' Atom x					{ Fix $ DocRetval $2 $3 }+|	'@return' x						{ Fix $ DocReturn $2 }+|	'@return' '\n' BulletListItemII				{ Fix $ DocReturn (Fix (DocLine []) : $3) }+|	'@see' CMT_WORD x					{ Fix $ DocSee $2 $3 }+|	'@deprecated' x						{ Fix $ DocDeprecated $2 }+|	'@implements' CMT_WORD					{ Fix $ DocImplements $2 }+|	'@extends' CMT_WORD					{ Fix $ DocExtends $2 }+|	'@private'						{ Fix DocPrivate }++BulletListItem :: { NonTerm }+BulletListItem+:	'-' Words '\n' BulletICont				{ Fix $ DocULItem $2 $4 }++BulletICont :: { [NonTerm] }+BulletICont+:								{ [] }+|	'INDENT1' DocLine '\n' BulletICont			{ $2 ++ $4 }+|	BulletListItemII					{ $1 }++BulletListItemII :: { [NonTerm] }+BulletListItemII+:	'INDENT1' '-' Words '\n' BulletIICont			{ Fix (DocULItem ($3 ++ snd $5) []) : fst $5 }++BulletIICont :: { ([NonTerm], [NonTerm]) }+BulletIICont+:								{ ([], []) }+|	BulletListItemII					{ ($1, []) }+|	'INDENT3' DocLine '\n' BulletIICont			{ ([], $2) <> $4 }++NumberedListItem :: { NonTerm }+NumberedListItem+:	LIT_INTEGER '.' IndentedSentenceII			{ Fix (DocOLItem $1 $3) }++IndentedSentenceII :: { [NonTerm] }+IndentedSentenceII+:	DocLine '\n'						{ $1 }+|	DocLine '\n' 'INDENT2' IndentedSentenceII		{ $1 ++ $4 }++Words :: { [NonTerm] }+Words+:	SentenceList(WordList)					{ $1 }++WordList :: { [NonTerm] }+WordList+:	Word(Atom)						{ [$1] }+|	WordList Word(Atom)					{ $2 : $1 }++SentenceList(x)+:	x							{ reverse $1 }+|	SentenceList(x) ';'					{ [Fix (DocSentence $1 $2)] }+|	SentenceList(x) ','					{ [Fix (DocSentence $1 $2)] }+|	SentenceList(x) '.'					{ [Fix (DocSentence $1 $2)] }+|	SentenceList(x) '?'					{ [Fix (DocSentence $1 $2)] }+|	SentenceList(x) '!'					{ [Fix (DocSentence $1 $2)] }+|	SentenceList(x) ';' SentenceList(x)			{ Fix (DocSentence $1 $2) : $3 }+|	SentenceList(x) ',' SentenceList(x)			{ Fix (DocSentence $1 $2) : $3 }+|	SentenceList(x) '.' SentenceList(x)			{ Fix (DocSentence $1 $2) : $3 }+|	SentenceList(x) '?' SentenceList(x)			{ Fix (DocSentence $1 $2) : $3 }+|	SentenceList(x) '!' SentenceList(x)			{ Fix (DocSentence $1 $2) : $3 }++Word(x)+:	x							{ Fix $ DocWord $1 }+|	x ':'							{ Fix $ DocColon $1 }+|	Word(x) '=' Word(Atom)					{ Fix $ DocAssignOp AopEq $1 $3 }+|	Word(x) '+' Word(Atom)					{ Fix $ DocBinaryOp BopPlus $1 $3 }+|	Word(x) '-' Word(Atom)					{ Fix $ DocBinaryOp BopMinus $1 $3 }+|	Word(x) '/' Word(Atom)					{ Fix $ DocBinaryOp BopDiv $1 $3 }+|	Word(x) '!=' Word(Atom)					{ Fix $ DocBinaryOp BopNe $1 $3 }+|	Word(x) '>=' Word(Atom)					{ Fix $ DocBinaryOp BopGe $1 $3 }+|	Word(x) '==' Word(Atom)					{ Fix $ DocBinaryOp BopEq $1 $3 }+|	'@ref' Atom						{ Fix $ DocRef $2 }+|	'@p' Atom						{ Fix $ DocP $2 }+|	'(' Word(Atom)						{ Fix $ DocLParen $2 }+|	Word(x) ')'						{ Fix $ DocRParen $1 }++Atom :: { Term }+Atom+:	NonInt							{ $1 }+|	LIT_INTEGER						{ $1 }++NonInt :: { Term }+NonInt+:	CMT_WORD						{ $1 }+|	CMT_CODE						{ $1 }+|	LIT_STRING						{ $1 }+|	'...'							{ $1 }++{+type Term = Lexeme Text+type NonTerm = Comment Term++prepend :: NonTerm -> [NonTerm] -> [NonTerm]+prepend x [] = [x]+prepend x (Fix (DocLine xs):rest) = Fix (DocLine (x:xs)) : rest++failAt :: Lexeme Text -> String -> ParseResult a+failAt n msg =+    fail $ Text.unpack (sloc "" n) <> ": unexpected " <> describeLexeme n <> msg++parseError :: ([Lexeme Text], [String]) -> ParseResult a+parseError ([], options)  = fail $ " end of comment; expected one of " <> show options+parseError (n:_, [])      = failAt n "; expected end of comment"+parseError (n:_, options) = failAt n $ "; expected one of " <> show options+}

@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict            #-}+{-# LANGUAGE StrictData        #-}+module Language.Cimple.DescribeAst+    ( HasLocation (..)+    , describeLexeme+    , describeNode+    ) where++import           Data.Fix                (Fix (..), foldFix)+import           Data.Text               (Text)+import qualified Data.Text               as Text+import           Language.Cimple.Ast     (Node, NodeF (..))+import qualified Language.Cimple.Flatten as Flatten+import           Language.Cimple.Lexer   (Lexeme, lexemeLine)+++class HasLocation a where+    sloc :: FilePath -> a -> Text++instance HasLocation (Lexeme text) where+    sloc file l = Text.pack file <> ":" <> Text.pack (show (lexemeLine l))++instance HasLocation lexeme => HasLocation (Node lexeme) where+    sloc file n =+        case foldFix Flatten.lexemes n of+            []  -> Text.pack file <> ":0:0"+            l:_ -> sloc file l+++describeNode :: Show a => Node a -> String+describeNode node = case unFix node of+    PreprocIf{}     -> "#if/#endif block"+    PreprocIfdef{}  -> "#ifdef/#endif block"+    PreprocIfndef{} -> "#ifndef/#endif block"+    _               -> show $ (const ellipsis) <$> unFix node+  where+    ellipsis :: String+    ellipsis = "..."++describeLexeme :: Show a => Lexeme a -> String+describeLexeme = show

@@ -9,14 +9,10 @@   , sloc   ) where -import           Control.Monad.State.Strict (State)-import qualified Control.Monad.State.Strict as State-import           Data.Fix                   (foldFix)-import           Data.Text                  (Text)-import qualified Data.Text                  as Text-import           Language.Cimple.Ast        (Node)-import qualified Language.Cimple.Flatten    as Flatten-import           Language.Cimple.Lexer      (Lexeme (..), lexemeLine)+import           Control.Monad.State.Strict  (State)+import qualified Control.Monad.State.Strict  as State+import           Data.Text                   (Text)+import           Language.Cimple.DescribeAst (HasLocation (..))  type DiagnosticsT diags a = State diags a type Diagnostics a = DiagnosticsT [Text] a@@ -32,16 +28,3 @@  instance HasDiagnostics [Text] where     addDiagnostic = (:)---class HasLocation a where-    sloc :: FilePath -> a -> Text--instance HasLocation (Lexeme text) where-    sloc file l = Text.pack file <> ":" <> Text.pack (show (lexemeLine l))--instance HasLocation lexeme => HasLocation (Node lexeme) where-    sloc file n =-        case foldFix Flatten.lexemes n of-            []  -> Text.pack file <> ":0:0"-            l:_ -> sloc file l

@@ -7,10 +7,12 @@ {-# LANGUAGE TypeOperators         #-} module Language.Cimple.Flatten (lexemes) where +import           Data.Fix            (Fix (..)) import           Data.Maybe          (maybeToList) import           GHC.Generics-import           Language.Cimple.Ast (AssignOp, BinaryOp, CommentStyle,-                                      LiteralType, NodeF (..), Scope, UnaryOp)+import           Language.Cimple.Ast (AssignOp, BinaryOp, CommentF,+                                      CommentStyle, LiteralType, NodeF (..),+                                      Scope, UnaryOp)  class Concats t a where     concats :: t -> [a]@@ -53,11 +55,15 @@ instance {-# OVERLAPPABLE #-} GenConcatsFlatten b a => GenConcatsFlatten [b] a where     gconcatsFlatten = concatMap gconcatsFlatten +instance GenConcatsFlatten (Fix (CommentF a)) a where+    gconcatsFlatten = error "TODO: gconcatsFlatten for CommentF"+ instance GenConcatsFlatten t a => GenConcats (Rec0 t) a where     gconcats (K1 x) = gconcatsFlatten x  -- Uses the default signature, which delegates to the generic stuff instance Concats (NodeF a [a]) a+instance Concats (CommentF a [a]) a  lexemes :: NodeF lexeme [lexeme] -> [lexeme] lexemes = concats

@@ -21,6 +21,7 @@ import           Language.Cimple.MapAst          (TextActions, mapAst,                                                   textActions) import qualified Language.Cimple.Parser          as Parser+import qualified Language.Cimple.ParseResult     as ParseResult import           Language.Cimple.Program         (Program) import qualified Language.Cimple.Program         as Program import           Language.Cimple.TranslationUnit (TranslationUnit)@@ -51,7 +52,7 @@  parseTextPedantic :: Text -> Either String [TextNode] parseTextPedantic =-    parseText >=> TreeParser.toEither . TreeParser.parseTranslationUnit+    parseText >=> ParseResult.toEither . TreeParser.parseTranslationUnit   parseFile :: FilePath -> IO (Either String (TranslationUnit Text))@@ -59,7 +60,7 @@     addSource . parseTextPedantic . Text.decodeUtf8 <$> BS.readFile source   where     -- Add source filename to the error message, if any.-    addSource (Left err) = Left $ source <> ":" <> err+    addSource (Left err) = Left $ source <> err     -- If there's no error message, record the source filename in the returned     -- TranslationUnit.     addSource (Right ok) = Right (source, ok)

@@ -29,7 +29,7 @@ tokens :-  -- Ignore attributes.-<0>		"GNU_PRINTF("[^\)]+")"			;+<0>		"GNU_PRINTF"				{ mkL KwGnuPrintf } <0>		"VLA"					{ mkL KwVla }  -- Winapi functions.@@ -104,12 +104,7 @@ <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 }-<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,ppSC>	"crypto_"[a-z0-9_]+[A-Z][A-Z0-9_]*	{ mkL IdConst }  -- Standard C (ish). <ppSC>		defined					{ mkL PpDefined }@@ -118,13 +113,13 @@ <ppSC>		\\\n					; <ppSC>		$white					; -<ignoreSC>	"//!TOKSTYLE+"				{ start 0 }-<ignoreSC>	[.\n]					;+<ignoreSC>	"//!TOKSTYLE+"				{ mkL IgnEnd `andBegin` 0 }+<ignoreSC>	([^\/]+|.|\n)				{ mkL IgnBody }  <0,ppSC>	"//"\n					; <0,ppSC>	"// ".*					; <0>		$white+					;-<0>		"//!TOKSTYLE-"				{ start ignoreSC }+<0>		"//!TOKSTYLE-"				{ mkL IgnStart `andBegin` ignoreSC } <0>		"/*"					{ mkL CmtStart `andBegin` cmtSC } <0>		"/**"					{ mkL CmtStartDoc `andBegin` cmtSC } <0>		"/** @{"				{ mkL CmtStartDocSection `andBegin` cmtSC }@@ -191,10 +186,10 @@ <0,ppSC>	[a-z][a-z0-9_]*_cb			{ mkL IdFuncType } <0,ppSC>	[a-z][A-Za-z0-9_]*			{ mkL IdVar } <0,ppSC,cmtSC>	[0-9]+[LU]*				{ mkL LitInteger }-<0,ppSC>	[0-9]+"."[0-9]+f?			{ mkL LitInteger }+<0,ppSC,cmtSC>	[0-9]+"."[0-9]+f?			{ mkL LitInteger } <0,ppSC>	0x[0-9a-fA-F]+[LU]*			{ mkL LitInteger } <0,ppSC,cmtSC>	"="					{ mkL PctEq }-<0,ppSC>	"=="					{ mkL PctEqEq }+<0,ppSC,cmtSC>	"=="					{ mkL PctEqEq } <0,ppSC>	"&"					{ mkL PctAmpersand } <0,ppSC>	"&&"					{ mkL PctAmpersandAmpersand } <0,ppSC>	"&="					{ mkL PctAmpersandEq }@@ -210,7 +205,7 @@ <0,ppSC,cmtSC>	"/"					{ mkL PctSlash } <0,ppSC>	"/="					{ mkL PctSlashEq } <0,ppSC,cmtSC>	"."					{ mkL PctPeriod }-<0,ppSC>	"..."					{ mkL PctEllipsis }+<0,ppSC,cmtSC>	"..."					{ mkL PctEllipsis } <0,ppSC>	"%"					{ mkL PctPercent } <0,ppSC>	"%="					{ mkL PctPercentEq } <0,ppSC,cmtSC>	";"					{ mkL PctSemicolon }@@ -222,7 +217,7 @@ <0,ppSC,cmtSC>	">"					{ mkL PctGreater } <0,ppSC>	">>"					{ mkL PctGreaterGreater } <0,ppSC>	">>="					{ mkL PctGreaterGreaterEq }-<0,ppSC>	">="					{ mkL PctGreaterEq }+<0,ppSC,cmtSC>	">="					{ mkL PctGreaterEq } <0,ppSC>	"|"					{ mkL PctPipe } <0,ppSC>	"||"					{ mkL PctPipePipe } <0,ppSC>	"|="					{ mkL PctPipeEq }@@ -234,7 +229,7 @@ <0,ppSC,cmtSC>	")"					{ mkL PctRParen } <0,ppSC,cmtSC>	"?"					{ mkL PctQMark } <0,ppSC,cmtSC>	"!"					{ mkL PctEMark }-<0,ppSC>	"!="					{ mkL PctEMarkEq }+<0,ppSC,cmtSC>	"!="					{ mkL PctEMarkEq } <0,ppSC>	"*"					{ mkL PctAsterisk } <0,ppSC>	"*="					{ mkL PctAsteriskEq } <0,ppSC>	"^"					{ mkL PctCaret }@@ -245,15 +240,26 @@ <cmtSC>		"SPDX-License-Identifier:"		{ mkL CmtSpdxLicense } <cmtSC>		"GPL-3.0-or-later"			{ mkL CmtWord } <cmtSC>		"TODO("[^\)]+"):"			{ mkL CmtWord }+<cmtSC>		[A-Z][A-Za-z]+"::"[a-z_]+		{ mkL CmtWord }+<cmtSC>		"E.g."					{ mkL CmtWord }+<cmtSC>		"e.g."					{ mkL CmtWord }+<cmtSC>		"etc."					{ mkL CmtWord }+<cmtSC>		"I.e."					{ mkL CmtWord }+<cmtSC>		"i.e."					{ mkL CmtWord }+<cmtSC>		[0-2][0-9](":"[0-5][0-9]){2}"."[0-9]{3}	{ mkL CmtWord }+<cmtSC>		"v"?[0-9]"."[0-9]"."[0-9]		{ mkL CmtWord } <cmtSC>		"@code"					{ mkL CmtCode `andBegin` codeSC } <cmtSC>		"<code>"				{ mkL CmtCode `andBegin` codeSC }+<cmtSC>		"["[^\]]+"]"				{ mkL CmtAttr }+<cmtSC>		"@retval"				{ mkL CmtCommand `andBegin` retvalSC } <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 } <cmtSC>		"#"[0-9]+				{ mkL CmtWord }-<cmtSC>		"http://"[^ ]+				{ mkL CmtWord }+<cmtSC>		"http://"[^\ ]+				{ mkL CmtWord } <cmtSC>		[0-9]+"%"				{ mkL LitInteger }+<cmtSC>		"-1"					{ mkL LitInteger } <cmtSC>		"`"([^`]|"\`")+"`"			{ mkL CmtCode } <cmtSC>		"${"([^\}])+"}"				{ mkL CmtCode } <cmtSC>		"–"					{ mkL CmtWord }@@ -261,26 +267,37 @@ <cmtSC>		\n					{ mkL PpNewline `andBegin` cmtNewlineSC } <cmtSC>		" "+					; +<retvalSC>	[^\ ]+					{ mkL CmtWord `andBegin` cmtSC }+<retvalSC>	" "+					;+ <cmtNewlineSC>	" "+"*"+"/"				{ mkL CmtEnd `andBegin` 0 }-<cmtNewlineSC>	" "+"*"					{ mkL CmtIndent `andBegin` cmtSC }+<cmtNewlineSC>	" "+"*"					{ begin cmtStartSC } +<cmtStartSC>	" "+					{ mkL CmtIndent `andBegin` cmtSC }+<cmtStartSC>	\n					{ mkL PpNewline `andBegin` cmtNewlineSC }++<codeStartSC>	" "+					{ mkL CmtIndent `andBegin` codeSC }+<codeStartSC>	\n					{ mkL PpNewline `andBegin` codeNewlineSC }++<codeNewlineSC>	" "+"*"					{ begin codeStartSC }+ -- <code></code> blocks in comments. <codeSC>	"@endcode"				{ mkL CmtCode `andBegin` cmtSC } <codeSC>	"</code>"				{ mkL CmtCode `andBegin` cmtSC }-<codeSC>	\n					{ mkL PpNewline }-<codeSC>	\n" "+"*"				{ mkL PpNewline }+<codeSC>	\n					{ mkL PpNewline `andBegin` codeNewlineSC } <codeSC>	[^@\<]+					{ mkL CmtCode }  -- Error handling.-<0,ppSC,cmtSC,codeSC>	.				{ mkL Error }+<0,ppSC,cmtSC,codeSC>	.				{ mkL ErrorToken }  {+deriving instance Ord AlexPosn deriving instance Generic AlexPosn instance FromJSON AlexPosn instance ToJSON AlexPosn  data Lexeme text = L AlexPosn LexemeClass text-    deriving (Show, Eq, Generic, Functor, Foldable, Traversable)+    deriving (Ord, Eq, Show, Generic, Functor, Foldable, Traversable)  instance FromJSON text => FromJSON (Lexeme text) instance ToJSON text => ToJSON (Lexeme text)

@@ -11,6 +11,7 @@      , doFiles, doFile     , doNodes, doNode+    , doComment, doComments     , doLexemes, doLexeme     , doText @@ -20,7 +21,8 @@     ) where  import           Data.Fix              (Fix (..))-import           Language.Cimple.Ast   (Node, NodeF (..))+import           Language.Cimple.Ast   (Comment, CommentF (..), Node,+                                        NodeF (..)) import           Language.Cimple.Lexer (Lexeme (..))  class MapAst itext otext a where@@ -39,13 +41,15 @@ mapAst = flip mapFileAst "<stdin>"  data AstActions f itext otext = AstActions-    { doFiles     :: [(FilePath, [Node (Lexeme itext)])] -> f [(FilePath, [Node (Lexeme otext)])] -> f [(FilePath, [Node (Lexeme otext)])]-    , doFile      ::  (FilePath, [Node (Lexeme itext)])  -> f  (FilePath, [Node (Lexeme otext)])  -> f  (FilePath, [Node (Lexeme otext)])-    , doNodes     :: FilePath -> [Node (Lexeme itext)]   -> f             [Node (Lexeme otext)]   -> f             [Node (Lexeme otext)]-    , doNode      :: FilePath ->  Node (Lexeme itext)    -> f             (Node (Lexeme otext))   -> f             (Node (Lexeme otext))-    , doLexemes   :: FilePath ->       [Lexeme itext]    -> f                   [Lexeme otext]    -> f                   [Lexeme otext]-    , doLexeme    :: FilePath ->        Lexeme itext     -> f                   (Lexeme otext)    -> f                   (Lexeme otext)-    , doText      :: FilePath ->               itext                                              -> f                           otext+    { doFiles     :: [(FilePath, [Node    (Lexeme itext)])] -> f [(FilePath, [Node    (Lexeme otext)])] -> f [(FilePath, [Node    (Lexeme otext)])]+    , doFile      ::  (FilePath, [Node    (Lexeme itext)])  -> f  (FilePath, [Node    (Lexeme otext)])  -> f  (FilePath, [Node    (Lexeme otext)])+    , doNodes     :: FilePath -> [Node    (Lexeme itext)]   -> f             [Node    (Lexeme otext)]   -> f             [Node    (Lexeme otext)]+    , doNode      :: FilePath ->  Node    (Lexeme itext)    -> f             (Node    (Lexeme otext))   -> f             (Node    (Lexeme otext))+    , doComment   :: FilePath ->  Comment (Lexeme itext)    -> f             (Comment (Lexeme otext))   -> f             (Comment (Lexeme otext))+    , doComments  :: FilePath -> [Comment (Lexeme itext)]   -> f             [Comment (Lexeme otext)]   -> f             [Comment (Lexeme otext)]+    , doLexemes   :: FilePath ->          [Lexeme itext]    -> f                      [Lexeme otext]    -> f                      [Lexeme otext]+    , doLexeme    :: FilePath ->           Lexeme itext     -> f                      (Lexeme otext)    -> f                      (Lexeme otext)+    , doText      :: FilePath ->                  itext                                                 -> f                              otext     }  instance MapAst itext otext        a@@ -64,6 +68,8 @@     , doFile      = const id     , doNodes     = const $ const id     , doNode      = const $ const id+    , doComment   = const $ const id+    , doComments  = const $ const id     , doLexeme    = const $ const id     , doLexemes   = const $ const id     , doText      = const ft@@ -92,6 +98,82 @@     mapFileAst actions@AstActions{..} currentFile = doLexemes currentFile <*>         traverse (mapFileAst actions currentFile) +instance MapAst itext otext (Comment (Lexeme itext)) where+    type Mapped itext otext (Comment (Lexeme itext))+                          =  Comment (Lexeme otext)+    mapFileAst+        :: forall f . Applicative f+        => AstActions f itext otext+        -> FilePath+        ->    Comment (Lexeme itext)+        -> f (Comment (Lexeme otext))+    mapFileAst actions@AstActions{..} currentFile = doComment currentFile <*> \comment -> case unFix comment of+        DocComment docs ->+            Fix <$> (DocComment <$> recurse docs)+        DocWord word ->+            Fix <$> (DocWord <$> recurse word)+        DocSentence docs ending ->+            Fix <$> (DocSentence <$> recurse docs <*> recurse ending)+        DocNewline -> pure $ Fix DocNewline++        DocAttention docs ->+            Fix <$> (DocAttention <$> recurse docs)+        DocBrief docs ->+            Fix <$> (DocBrief <$> recurse docs)+        DocDeprecated docs ->+            Fix <$> (DocDeprecated <$> recurse docs)+        DocExtends feat ->+            Fix <$> (DocExtends <$> recurse feat)+        DocImplements feat ->+            Fix <$> (DocImplements <$> recurse feat)+        DocParam attr name docs ->+            Fix <$> (DocParam <$> recurse attr <*> recurse name <*> recurse docs)+        DocReturn docs ->+            Fix <$> (DocReturn <$> recurse docs)+        DocRetval expr docs ->+            Fix <$> (DocRetval <$> recurse expr <*> recurse docs)+        DocSee ref docs ->+            Fix <$> (DocSee <$> recurse ref <*> recurse docs)++        DocPrivate -> pure $ Fix DocPrivate++        DocParagraph docs ->+            Fix <$> (DocParagraph <$> recurse docs)+        DocLine docs ->+            Fix <$> (DocLine <$> recurse docs)+        DocList docs ->+            Fix <$> (DocList <$> recurse docs)+        DocOLItem docs sublist ->+            Fix <$> (DocOLItem <$> recurse docs <*> recurse sublist)+        DocULItem docs sublist ->+            Fix <$> (DocULItem <$> recurse docs <*> recurse sublist)++        DocColon docs ->+            Fix <$> (DocColon <$> recurse docs)+        DocRef doc ->+            Fix <$> (DocRef <$> recurse doc)+        DocP doc ->+            Fix <$> (DocP <$> recurse doc)+        DocLParen docs ->+            Fix <$> (DocLParen <$> recurse docs)+        DocRParen docs ->+            Fix <$> (DocRParen <$> recurse docs)+        DocAssignOp op lhs rhs ->+            Fix <$> (DocAssignOp op <$> recurse lhs <*> recurse rhs)+        DocBinaryOp op lhs rhs ->+            Fix <$> (DocBinaryOp op <$> recurse lhs <*> recurse rhs)++      where+        recurse :: MapAst itext otext a => a -> f (Mapped itext otext a)+        recurse = mapFileAst actions currentFile++instance MapAst itext otext [Comment (Lexeme itext)] where+    type Mapped itext otext [Comment (Lexeme itext)]+                          = [Comment (Lexeme otext)]+    mapFileAst actions@AstActions{..} currentFile = doComments currentFile <*>+        traverse (mapFileAst actions currentFile)++ instance MapAst itext otext (Node (Lexeme itext)) where     type Mapped itext otext (Node (Lexeme itext))                           =  Node (Lexeme otext)@@ -140,12 +222,18 @@             Fix <$> (CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner)         Comment doc start contents end ->             Fix <$> (Comment doc <$> recurse start <*> recurse contents <*> recurse end)+        CommentSection start decls end ->+            Fix <$> (CommentSection <$> recurse start <*> recurse decls <*> recurse end)         CommentSectionEnd comment ->             Fix <$> (CommentSectionEnd <$> recurse comment)         Commented comment subject ->             Fix <$> (Commented <$> recurse comment <*> recurse subject)+        CommentInfo comment ->+            Fix <$> (CommentInfo <$> recurse comment)         ExternC decls ->             Fix <$> (ExternC <$> recurse decls)+        Group decls ->+            Fix <$> (Group <$> recurse decls)         CompoundStmt stmts ->             Fix <$> (CompoundStmt <$> recurse stmts)         Break ->@@ -248,6 +336,8 @@             Fix <$> (TyStd <$> recurse name)         TyUserDefined name ->             Fix <$> (TyUserDefined <$> recurse name)+        AttrPrintf fmt ellipsis fun ->+            Fix <$> (AttrPrintf <$> recurse fmt <*> recurse ellipsis <*> recurse fun)         FunctionDecl scope proto ->             Fix <$> (FunctionDecl scope <$> recurse proto)         FunctionDefn scope proto body ->

@@ -0,0 +1,11 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Language.Cimple.ParseResult+    ( ParseResult+    , toEither+    ) where++newtype ParseResult a = ParseResult { toEither :: Either String a }+    deriving (Functor, Applicative, Monad)++instance MonadFail ParseResult where+    fail = ParseResult . Left

@@ -22,7 +22,7 @@ %errorhandlertype explist %lexer {lexwrap} {L _ Eof _} %monad {Alex}-%tokentype {Lexeme String}+%tokentype {StringLexeme} %token     ID_CONST			{ L _ IdConst			_ }     ID_FUNC_TYPE		{ L _ IdFuncType		_ }@@ -39,6 +39,7 @@     enum			{ L _ KwEnum			_ }     extern			{ L _ KwExtern			_ }     for				{ L _ KwFor			_ }+    GNU_PRINTF			{ L _ KwGnuPrintf		_ }     goto			{ L _ KwGoto			_ }     if				{ L _ KwIf			_ }     non_null			{ L _ KwNonNull			_ }@@ -122,14 +123,19 @@     '/** @{'			{ L _ CmtStartDocSection	_ }     '/** @} */'			{ L _ CmtEndDocSection		_ }     '/***'			{ L _ CmtStartBlock		_ }-    ' * '			{ L _ CmtIndent			_ }+    ' * '			{ L _ CmtPrefix			_ }+    ' '				{ L _ CmtIndent			_ }     '*/'			{ L _ CmtEnd			_ }     'Copyright'			{ L _ CmtSpdxCopyright		_ }     'License'			{ L _ CmtSpdxLicense		_ }+    CMT_ATTR			{ L _ CmtAttr			_ }     CMT_CODE			{ L _ CmtCode			_ }     CMT_COMMAND			{ L _ CmtCommand		_ }     CMT_WORD			{ L _ CmtWord			_ }     CMT_REF			{ L _ CmtRef			_ }+    IGN_START			{ L _ IgnStart			_ }+    IGN_BODY			{ L _ IgnBody			_ }+    IGN_END			{ L _ IgnEnd			_ }  %left ',' %right '=' '+=' '-=' '*=' '/=' '%=' '<<=' '>>=' '&=' '^=' '|='@@ -149,23 +155,23 @@  %% -TranslationUnit :: { [StringNode] }+TranslationUnit :: { [NonTerm] } TranslationUnit :	ToplevelDecls						{ reverse $1 } |	LicenseDecl ToplevelDecls				{ $1 : reverse $2 } -LicenseDecl :: { StringNode }+LicenseDecl :: { NonTerm } LicenseDecl :	'/*' 'License' CMT_WORD '\n' CopyrightDecls '*/'	{ Fix $ LicenseDecl $3 (reverse $5) } -CopyrightDecls :: { [StringNode] }+CopyrightDecls :: { [NonTerm] } CopyrightDecls :	CopyrightDecl						{ [$1] } |	CopyrightDecls CopyrightDecl				{ $2 : $1 } -CopyrightDecl :: { StringNode }+CopyrightDecl :: { NonTerm } CopyrightDecl-:	' * ' 'Copyright' CopyrightDates CopyrightOwner '\n'	{ Fix $ CopyrightDecl (fst $3) (snd $3) $4 }+:	' ' 'Copyright' CopyrightDates CopyrightOwner '\n'	{ Fix $ CopyrightDecl (fst $3) (snd $3) $4 }  CopyrightDates :: { (StringLexeme, Maybe StringLexeme) } CopyrightDates@@ -176,12 +182,12 @@ CopyrightOwner :	CMT_WORD CommentWords					{ $1 : reverse $2 } -ToplevelDecls :: { [StringNode] }+ToplevelDecls :: { [NonTerm] } ToplevelDecls :	ToplevelDecl						{ [$1] } |	ToplevelDecls ToplevelDecl				{ $2 : $1 } -ToplevelDecl :: { StringNode }+ToplevelDecl :: { NonTerm } ToplevelDecl :	AggregateDecl						{ $1 } |	Comment							{ $1 }@@ -197,17 +203,18 @@ |	StaticAssert						{ $1 } |	TypedefDecl						{ $1 } -StaticAssert :: { StringNode }+StaticAssert :: { NonTerm } StaticAssert :	static_assert '(' ConstExpr ',' LIT_STRING ')' ';'	{ Fix $ StaticAssert $3 $5 } -Comment :: { StringNode }+Comment :: { NonTerm } 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 Section $1 (reverse $2) $3 } |	'/***' CommentTokens '*/'				{ Fix $ Comment Block $1 (reverse $2) $3 } |	'/** @} */'						{ Fix $ CommentSectionEnd $1 }+|	Ignore							{ $1 }  CommentTokens :: { [StringLexeme] } CommentTokens@@ -219,6 +226,7 @@ :	CommentWord						{ $1 } |	'\n'							{ $1 } |	' * '							{ $1 }+|	' '							{ $1 }  CommentWords :: { [StringLexeme] } CommentWords@@ -229,11 +237,13 @@ CommentWord :	CMT_WORD						{ $1 } |	CMT_COMMAND						{ $1 }+|	CMT_ATTR						{ $1 } |	CMT_REF							{ $1 } |	CMT_CODE						{ $1 } |	LIT_INTEGER						{ $1 } |	LIT_STRING						{ $1 } |	'.'							{ $1 }+|	'...'							{ $1 } |	'?'							{ $1 } |	'!'							{ $1 } |	','							{ $1 }@@ -247,7 +257,19 @@ |	'+'							{ $1 } |	'-'							{ $1 } |	'='							{ $1 }+|	'=='							{ $1 }+|	'!='							{ $1 }+|	'>='							{ $1 } +Ignore :: { NonTerm }+Ignore+:	IGN_START IgnoreBody IGN_END				{ Fix $ Comment Ignore $1 (reverse $2) $3 }++IgnoreBody :: { [StringLexeme] }+IgnoreBody+:	IGN_BODY						{ [$1] }+|	IgnoreBody IGN_BODY					{ $2 : $1 }+ PreprocIfdef(decls) :	'#ifdef' ID_CONST decls PreprocElse(decls) '#endif'	{ Fix $ PreprocIfdef $2 (reverse $3) $4 } |	'#ifndef' ID_CONST decls PreprocElse(decls) '#endif'	{ Fix $ PreprocIfndef $2 (reverse $3) $4 }@@ -263,47 +285,47 @@ :								{ Fix $ PreprocElse [] } |	'#else' decls						{ Fix $ PreprocElse (reverse $2) } -PreprocInclude :: { StringNode }+PreprocInclude :: { NonTerm } PreprocInclude :	'#include' LIT_STRING					{ Fix $ PreprocInclude $2 } |	'#include' LIT_SYS_INCLUDE				{ Fix $ PreprocInclude $2 } -PreprocDefine :: { StringNode }+PreprocDefine :: { NonTerm } PreprocDefine :	'#define' ID_CONST '\n'					{ Fix $ PreprocDefine $2 } |	'#define' ID_CONST PreprocSafeExpr(ConstExpr) '\n'	{ Fix $ PreprocDefineConst $2 $3 } |	'#define' ID_CONST MacroParamList MacroBody '\n'	{ Fix $ PreprocDefineMacro $2 $3 $4 } -PreprocUndef :: { StringNode }+PreprocUndef :: { NonTerm } PreprocUndef :	'#undef' ID_CONST					{ Fix $ PreprocUndef $2 } -PreprocConstExpr :: { StringNode }+PreprocConstExpr :: { NonTerm } PreprocConstExpr :	PureExpr(PreprocConstExpr)				{ $1 } |	'defined' '(' ID_CONST ')'				{ Fix $ PreprocDefined $3 } -MacroParamList :: { [StringNode] }+MacroParamList :: { [NonTerm] } MacroParamList :	'(' ')'							{ [] } |	'(' MacroParams ')'					{ reverse $2 } |	'(' MacroParams ',' '...' ')'				{ reverse $ Fix Ellipsis : $2 } -MacroParams :: { [StringNode] }+MacroParams :: { [NonTerm] } MacroParams :	MacroParam						{ [$1] } |	MacroParams ',' MacroParam				{ $3 : $1 } -MacroParam :: { StringNode }+MacroParam :: { NonTerm } MacroParam :	ID_VAR							{ Fix $ MacroParam $1 } -MacroBody :: { StringNode }+MacroBody :: { NonTerm } MacroBody :	do CompoundStmt while '(' LIT_INTEGER ')'		{% macroBodyStmt $2 $5 } |	FunctionCall						{ Fix $ MacroBodyFunCall $1 } -ExternC :: { StringNode }+ExternC :: { NonTerm } ExternC :	'#ifdef' ID_CONST 	extern LIT_STRING '{'@@ -313,12 +335,12 @@ 	'}' 	'#endif'						{% externC $2 $4 (reverse $7) $9 } -Stmts :: { [StringNode] }+Stmts :: { [NonTerm] } Stmts :	Stmt							{ [$1] } |	Stmts Stmt						{ $2 : $1 } -Stmt :: { StringNode }+Stmt :: { NonTerm } Stmt :	PreprocIfdef(Stmts)					{ $1 } |	PreprocIf(Stmts)					{ $1 }@@ -329,6 +351,7 @@ |	ForStmt							{ $1 } |	WhileStmt						{ $1 } |	DoWhileStmt						{ $1 }+|	StaticAssert						{ $1 } |	AssignExpr ';'						{ Fix $ ExprStmt $1 } |	ExprStmt ';'						{ Fix $ ExprStmt $1 } |	FunctionCall ';'					{ Fix $ ExprStmt $1 }@@ -341,96 +364,96 @@ |	switch '(' Expr ')' '{' SwitchCases '}'			{ Fix $ SwitchStmt $3 (reverse $6) } |	Comment							{ $1 } -IfStmt :: { StringNode }+IfStmt :: { NonTerm } IfStmt :	if '(' Expr ')' CompoundStmt				{ Fix $ IfStmt $3 $5 Nothing } |	if '(' Expr ')' CompoundStmt else IfStmt		{ Fix $ IfStmt $3 $5 (Just $7) } |	if '(' Expr ')' CompoundStmt else CompoundStmt		{ Fix $ IfStmt $3 $5 (Just $7) } -ForStmt :: { StringNode }+ForStmt :: { NonTerm } ForStmt :	for '(' ForInit Expr ';' ForNext ')' CompoundStmt	{ Fix $ ForStmt $3 $4 $6 $8 } -ForInit :: { StringNode }+ForInit :: { NonTerm } ForInit :	AssignExpr ';'						{ Fix $ ExprStmt $1 } |	VarDeclStmt						{ $1 } -ForNext :: { StringNode }+ForNext :: { NonTerm } ForNext :	ExprStmt						{ $1 } |	AssignExpr						{ $1 } -WhileStmt :: { StringNode }+WhileStmt :: { NonTerm } WhileStmt :	while '(' Expr ')' CompoundStmt				{ Fix $ WhileStmt $3 $5 } -DoWhileStmt :: { StringNode }+DoWhileStmt :: { NonTerm } DoWhileStmt :	do CompoundStmt while '(' Expr ')' ';'			{ Fix $ DoWhileStmt $2 $5 } -SwitchCases :: { [StringNode] }+SwitchCases :: { [NonTerm] } SwitchCases :	SwitchCase						{ [$1] } |	SwitchCases SwitchCase					{ $2 : $1 } -SwitchCase :: { StringNode }+SwitchCase :: { NonTerm } SwitchCase :	case Expr ':' SwitchCaseBody				{ Fix $ Case $2 $4 } |	default ':' SwitchCaseBody				{ Fix $ Default $3 } -SwitchCaseBody :: { StringNode }+SwitchCaseBody :: { NonTerm } SwitchCaseBody :	CompoundStmt						{ $1 } |	SwitchCase						{ $1 } |	return Expr ';'						{ Fix $ Return (Just $2) } -DeclStmt :: { StringNode }+DeclStmt :: { NonTerm } DeclStmt :	VarDeclStmt						{ $1 } |	VLA '(' QualType ',' ID_VAR ',' Expr ')' ';'		{ Fix $ VLA $3 $5 $7 } -VarDeclStmt :: { StringNode }+VarDeclStmt :: { NonTerm } VarDeclStmt :	VarDecl '=' InitialiserExpr ';'				{ Fix $ VarDeclStmt $1 (Just $3) } |	VarDecl ';'						{ Fix $ VarDeclStmt $1 Nothing } -VarDecl :: { StringNode }+VarDecl :: { NonTerm } 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 :: { [NonTerm] } DeclSpecArrays :								{ [] } |	DeclSpecArrays DeclSpecArray				{ $2 : $1 } -DeclSpecArray :: { StringNode }+DeclSpecArray :: { NonTerm } DeclSpecArray :	'[' ']'							{ Fix $ DeclSpecArray Nothing } |	'[' Expr ']'						{ Fix $ DeclSpecArray (Just $2) } -InitialiserExpr :: { StringNode }+InitialiserExpr :: { NonTerm } InitialiserExpr :	InitialiserList						{ Fix $ InitialiserList $1 } |	Expr							{ $1 } -InitialiserList :: { [StringNode] }+InitialiserList :: { [NonTerm] } InitialiserList :	'{' Initialisers '}'					{ reverse $2 } |	'{' Initialisers ',' '}'				{ reverse $2 } -Initialisers :: { [StringNode] }+Initialisers :: { [NonTerm] } Initialisers :	Initialiser						{ [$1] } |	Initialisers ',' Initialiser				{ $3 : $1 } -Initialiser :: { StringNode }+Initialiser :: { NonTerm } Initialiser :	Expr							{ $1 } |	InitialiserList						{ Fix $ InitialiserList $1 } -CompoundStmt :: { StringNode }+CompoundStmt :: { NonTerm } CompoundStmt :	'{' Stmts '}'						{ Fix $ CompoundStmt (reverse $2) } @@ -439,10 +462,10 @@ :	LiteralExpr						{ $1 } |	'(' x ')'						{ Fix $ ParenExpr $2 } |	'(' QualType ')' x %prec CAST				{ Fix $ CastExpr $2 $4 }-|	sizeof '(' x ')'					{ Fix $ SizeofExpr $3 }+|	sizeof '(' Expr ')'					{ Fix $ SizeofExpr $3 } |	sizeof '(' QualType ')'					{ Fix $ SizeofType $3 } -ConstExpr :: { StringNode }+ConstExpr :: { NonTerm } ConstExpr :	PureExpr(ConstExpr)					{ $1 } @@ -472,7 +495,7 @@ |	'-' x %prec NEG						{ Fix $ UnaryExpr UopMinus $2 } |	'&' x %prec ADDRESS					{ Fix $ UnaryExpr UopAddress $2 } -LiteralExpr :: { StringNode }+LiteralExpr :: { NonTerm } LiteralExpr :	StringLiteralExpr					{ $1 } |	LIT_CHAR						{ Fix $ LiteralExpr Char $1 }@@ -481,12 +504,12 @@ |	LIT_TRUE						{ Fix $ LiteralExpr Bool $1 } |	ID_CONST						{ Fix $ LiteralExpr ConstId $1 } -StringLiteralExpr :: { StringNode }+StringLiteralExpr :: { NonTerm } StringLiteralExpr :	LIT_STRING						{ Fix $ LiteralExpr String $1 } |	StringLiteralExpr LIT_STRING				{ $1 } -LhsExpr :: { StringNode }+LhsExpr :: { NonTerm } LhsExpr :	ID_VAR							{ Fix $ VarExpr $1 } |	'*' LhsExpr %prec DEREF					{ Fix $ UnaryExpr UopDeref $2 }@@ -494,7 +517,7 @@ |	LhsExpr '->' ID_VAR					{ Fix $ PointerAccess $1 $3 } |	LhsExpr '[' Expr ']'					{ Fix $ ArrayAccess $1 $3 } -Expr :: { StringNode }+Expr :: { NonTerm } Expr :	LhsExpr							{ $1 } |	ExprStmt						{ $1 }@@ -503,11 +526,11 @@ |	PureExpr(Expr)						{ $1 }  -- Allow `(Type){0}` to set struct values to all-zero.-CompoundLiteral :: { StringNode }+CompoundLiteral :: { NonTerm } CompoundLiteral :	'(' QualType ')' '{' ZeroInitExpr '}'			{ Fix $ CompoundLiteral $2 $5 } -ZeroInitExpr :: { StringNode }+ZeroInitExpr :: { NonTerm } ZeroInitExpr :	ID_VAR							{ Fix $ VarExpr $1 } |	LIT_CHAR						{ Fix $ LiteralExpr Char $1 }@@ -516,7 +539,7 @@ |	ID_CONST						{ Fix $ LiteralExpr ConstId $1 } |	'{' ZeroInitExpr '}'					{ Fix $ InitialiserList [$2] } -AssignExpr :: { StringNode }+AssignExpr :: { NonTerm } AssignExpr :	LhsExpr AssignOperator Expr				{ Fix $ AssignExpr $1 $2 $3 } @@ -534,118 +557,127 @@ |	'<<='							{ AopLsh     } |	'>>='							{ AopRsh     } -ExprStmt :: { StringNode }+ExprStmt :: { NonTerm } ExprStmt :	'++' Expr						{ Fix $ UnaryExpr UopIncr $2 } |	'--' Expr						{ Fix $ UnaryExpr UopDecr $2 } -FunctionCall :: { StringNode }+FunctionCall :: { NonTerm } FunctionCall :	Expr ArgList						{ Fix $ FunctionCall $1 $2 } -ArgList :: { [StringNode] }+ArgList :: { [NonTerm] } ArgList :	'(' ')'							{ [] } |	'(' Args ')'						{ reverse $2 } -Args :: { [StringNode] }+Args :: { [NonTerm] } Args :	Arg							{ [$1] } |	Args ',' Arg						{ $3 : $1 } -Arg :: { StringNode }+Arg :: { NonTerm } Arg :	Expr							{ $1 } |	Comment Expr						{ Fix $ CommentExpr $1 $2 } -EnumDecl :: { StringNode }+EnumDecl :: { NonTerm } EnumDecl :	enum ID_SUE_TYPE EnumeratorList ';'			{ Fix $ EnumConsts (Just $2) $3 } |	enum             EnumeratorList ';'			{ Fix $ EnumConsts Nothing $2 } |	typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';'	{ Fix $ EnumDecl $3 $4 $5 } -EnumeratorList :: { [StringNode] }+EnumeratorList :: { [NonTerm] } EnumeratorList :	'{' Enumerators '}'					{ reverse $2 } -Enumerators :: { [StringNode] }+Enumerators :: { [NonTerm] } Enumerators :	Enumerator						{ [$1] } |	Enumerators Enumerator					{ $2 : $1 } -Enumerator :: { StringNode }+Enumerator :: { NonTerm } Enumerator :	EnumeratorName ','					{ Fix $ Enumerator $1 Nothing } |	EnumeratorName '=' ConstExpr ','			{ Fix $ Enumerator $1 (Just $3) } |	Comment							{ $1 } -EnumeratorName :: { Lexeme String }+EnumeratorName :: { StringLexeme } EnumeratorName :	ID_CONST						{ $1 } |	ID_SUE_TYPE						{ $1 } -AggregateDecl :: { StringNode }+AggregateDecl :: { NonTerm } AggregateDecl :	AggregateType ';'					{ Fix $ AggregateDecl $1 } |	typedef AggregateType ID_SUE_TYPE ';'			{ Fix $ Typedef $2 $3 } -AggregateType :: { StringNode }+AggregateType :: { NonTerm } AggregateType :	struct ID_SUE_TYPE '{' MemberDeclList '}'		{ Fix $ Struct $2 $4 } |	union ID_SUE_TYPE '{' MemberDeclList '}'		{ Fix $ Union $2 $4 } -MemberDeclList :: { [StringNode] }+MemberDeclList :: { [NonTerm] } MemberDeclList :	MemberDecls						{ reverse $1 } -MemberDecls :: { [StringNode] }+MemberDecls :: { [NonTerm] } MemberDecls :	MemberDecl						{ [$1] } |	MemberDecls MemberDecl					{ $2 : $1 } -MemberDecl :: { StringNode }+MemberDecl :: { NonTerm } MemberDecl :	VarDecl ';'						{ Fix $ MemberDecl $1 Nothing } |	VarDecl ':' LIT_INTEGER ';'				{ Fix $ MemberDecl $1 (Just $3) } |	PreprocIfdef(MemberDeclList)				{ $1 } |	Comment							{ $1 } -TypedefDecl :: { StringNode }+TypedefDecl :: { NonTerm } TypedefDecl :	typedef QualType ID_SUE_TYPE ';'			{ Fix $ Typedef $2 $3 } |	typedef FunctionPrototype(ID_FUNC_TYPE) ';'		{ Fix $ TypedefFunction $2 } -QualType :: { StringNode }+QualType :: { NonTerm } QualType-:	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						{                                        $1 }+|	LeafType '*'						{                              tyPointer $1 }+|	LeafType '*' '*'					{          tyPointer          (tyPointer $1) }+|	LeafType '*' '*' const					{ tyConst (tyPointer          (tyPointer $1)) }+|	LeafType '*' const					{                     tyConst (tyPointer $1) }+|	LeafType '*' const '*'					{          tyPointer (tyConst (tyPointer $1)) }+|	LeafType '*' const '*' const				{ tyConst (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))) }+|	LeafType const '*' const '*' const			{ tyConst (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))) }+|	const LeafType '*' const '*' const			{ tyConst (tyPointer (tyConst (tyPointer (tyConst $2)))) } -LeafType :: { StringNode }+LeafType :: { NonTerm } LeafType :	struct ID_SUE_TYPE					{ Fix $ TyStruct $2 } |	void							{ Fix $ TyStd $1 } |	ID_STD_TYPE						{ Fix $ TyStd $1 } |	ID_SUE_TYPE						{ Fix $ TyUserDefined $1 } -FunctionDecl :: { StringNode }+FunctionDecl :: { NonTerm } FunctionDecl :	FunctionDeclarator					{ $1 Global } |	static FunctionDeclarator				{ $2 Static } |	NonNull FunctionDeclarator				{ $1 $ $2 Global } |	NonNull static FunctionDeclarator			{ $1 $ $3 Static }+|	NonNull Attrs FunctionDeclarator			{ $1 . $2 . $3 $ Global } -NonNull :: { StringNode -> StringNode }+Attrs :: { NonTerm -> NonTerm }+Attrs+:	GNU_PRINTF '(' LIT_INTEGER ',' LIT_INTEGER ')'		{ Fix . AttrPrintf $3 $5 }++NonNull :: { NonTerm -> NonTerm } NonNull :	non_null '(' ')'					{ Fix . NonNull [] [] } |	nullable '(' Ints ')'					{ Fix . NonNull [] $3 }@@ -660,13 +692,13 @@ :	LIT_INTEGER						{ [$1] } |	IntList ',' LIT_INTEGER					{ $3 : $1 } -FunctionDeclarator :: { Scope -> StringNode }+FunctionDeclarator :: { Scope -> NonTerm } 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 :: { NonTerm } CallbackDecl :	ID_FUNC_TYPE ID_VAR					{ Fix $ CallbackDecl $1 $2 } @@ -674,23 +706,23 @@ :	QualType id FunctionParamList				{ Fix $ FunctionPrototype $1 $2 $3 } |	ID_FUNC_TYPE '*' id FunctionParamList			{ Fix $ FunctionPrototype (Fix $ TyPointer $ Fix $ TyFunc $1) $3 $4 } -FunctionParamList :: { [StringNode] }+FunctionParamList :: { [NonTerm] } FunctionParamList :	'(' ')'							{ [] } |	'(' void ')'						{ [Fix $ TyStd $2] } |	'(' FunctionParams ')'					{ reverse $2 } |	'(' FunctionParams ',' '...' ')'			{ reverse $ Fix Ellipsis : $2 } -FunctionParams :: { [StringNode] }+FunctionParams :: { [NonTerm] } FunctionParams :	FunctionParam						{ [$1] } |	FunctionParams ',' FunctionParam			{ $3 : $1 } -FunctionParam :: { StringNode }+FunctionParam :: { NonTerm } FunctionParam :	VarDecl							{ $1 } -ConstDecl :: { StringNode }+ConstDecl :: { NonTerm } ConstDecl :	extern const LeafType ID_VAR ';'			{ Fix $ ConstDecl $3 $4 } |	const LeafType ID_VAR '=' InitialiserExpr ';'		{ Fix $ ConstDefn Global $2 $3 $5 }@@ -698,15 +730,15 @@  { type StringLexeme = Lexeme String-type StringNode = Node StringLexeme+type NonTerm = Node StringLexeme -tyPointer, tyConst :: StringNode -> StringNode+tyPointer, tyConst :: NonTerm -> NonTerm tyPointer = Fix . TyPointer tyConst = Fix . TyConst  parseError :: Show text => (Lexeme text, [String]) -> Alex a parseError (L (AlexPn _ line col) c t, options) =-    alexError $ show line <> ":" <> show col <> ": Parse error near " <> show c <> ": "+    alexError $ ":" <> show line <> ":" <> show col <> ": Parse error near " <> show c <> ": "         <> show t <> "; expected one of " <> show options  lexwrap :: (Lexeme String -> Alex a) -> Alex a@@ -715,9 +747,9 @@ externC     :: Lexeme String     -> Lexeme String-    -> [StringNode]+    -> [NonTerm]     -> Lexeme String-    -> Alex StringNode+    -> Alex NonTerm externC (L _ _ "__cplusplus") (L _ _ "\"C\"") decls (L _ _ "__cplusplus") =     return $ Fix $ ExternC decls externC _ lang _ _ =@@ -725,9 +757,9 @@         <> ": extern \"C\" declaration invalid (did you spell __cplusplus right?)"  macroBodyStmt-    :: StringNode+    :: NonTerm     -> Lexeme String-    -> Alex StringNode+    -> Alex NonTerm macroBodyStmt decls (L _ _ "0") =     return $ Fix $ MacroBodyStmt decls macroBodyStmt _ cond =

@@ -1,21 +1,30 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}-module Language.Cimple.Pretty (plain, ppTranslationUnit, showNode) where+module Language.Cimple.Pretty+    ( plain+    , render+    , ppTranslationUnit+    , showNode+    ) where  import           Data.Fix                     (foldFix) import qualified Data.List.Split              as List import           Data.Text                    (Text) import qualified Data.Text                    as Text import           Language.Cimple              (AssignOp (..), BinaryOp (..),+                                               Comment, CommentF (..),                                                CommentStyle (..), Lexeme (..),                                                LexemeClass (..), Node,                                                NodeF (..), Scope (..),-                                               UnaryOp (..), lexemeText)+                                               UnaryOp (..), lexemeLine,+                                               lexemeText) import           Prelude                      hiding ((<$>)) import           Text.PrettyPrint.ANSI.Leijen +indentWidth :: Int+indentWidth = 2+ kwBreak         = dullred   $ text "break" kwCase          = dullred   $ text "case" kwConst         = dullgreen $ text "const"@@ -26,6 +35,7 @@ kwEnum          = dullgreen $ text "enum" kwExtern        = dullgreen $ text "extern" kwFor           = dullred   $ text "for"+kwGnuPrintf     = dullgreen $ text "GNU_PRINTF" kwGoto          = dullred   $ text "goto" kwIf            = dullred   $ text "if" kwNonNull       = dullgreen $ text "non_null"@@ -40,6 +50,22 @@ kwUnion         = dullgreen $ text "union" kwWhile         = dullred   $ text "while" +kwDocAttention  = dullcyan $ text "@attention"+kwDocBrief      = dullcyan $ text "@brief"+kwDocDeprecated = dullcyan $ text "@deprecated"+kwDocExtends    = dullcyan $ text "@extends"+kwDocImplements = dullcyan $ text "@implements"+kwDocParam      = dullcyan $ text "@param"+kwDocPrivate    = dullcyan $ text "@private"+kwDocRef        = dullcyan $ text "@ref"+kwDocReturn     = dullcyan $ text "@return"+kwDocRetval     = dullcyan $ text "@retval"+kwDocP          = dullcyan $ text "@p"+kwDocSee        = dullcyan $ text "@see"++cmtPrefix :: Doc+cmtPrefix = dullyellow (char '*')+ ppText :: Text -> Doc ppText = text . Text.unpack @@ -99,32 +125,43 @@     UopIncr    -> text "++"     UopDecr    -> text "--" -ppCommentStyle :: CommentStyle -> Doc-ppCommentStyle = dullyellow . \case+ppCommentStart :: CommentStyle -> Doc+ppCommentStart = dullyellow . \case     Block   -> text "/***"     Doxygen -> text "/**"+    Section -> text "/** @{"     Regular -> text "/*"+    Ignore  -> text "//!TOKSTYLE-"  ppCommentBody :: [Lexeme Text] -> Doc-ppCommentBody = vsep . map (hsep . map ppWord) . groupLines+ppCommentBody body = vsep . prefixStars . map (hsep . map ppWord) . groupLines $ body   where+    -- If the "*/" is on a separate line, don't add an additional "*" before+    -- it. If "*/" is on the same line, then do add a "*" prefix on the last line.+    stars =+        case reverse body of+          e:c:_ | lexemeLine e > lexemeLine c -> 2+          _                                   -> 1+    prefixStars xs = zipWith (<>) (empty : replicate (length xs - stars) cmtPrefix ++ [empty]) xs     groupLines = List.splitWhen $ \case         L _ PpNewline _ -> True         _               -> False -    ppWord (L _ CmtIndent  _) = dullyellow $ char '*'-    ppWord (L _ CmtCommand t) = dullcyan   $ ppText t-    ppWord (L _ _          t) = dullyellow $ ppText t+ppWord (L _ CmtIndent  _) = empty+ppWord (L _ CmtCommand t) = dullcyan   $ ppText t+ppWord (L _ _          t) = dullyellow $ ppText t  ppComment :: CommentStyle -> [Lexeme Text] -> Lexeme Text -> Doc+ppComment Ignore cs _ =+    ppCommentStart Ignore <> hcat (map ppWord cs) <> dullyellow (text "//!TOKSTYLE+" <> line) ppComment style cs (L l c _) =-    nest 1 $ ppCommentStyle style <+> ppCommentBody (cs ++ [L l c "*/"])+    nest 1 $ ppCommentStart style <+> ppCommentBody (cs ++ [L l c "*/"])  ppInitialiserList :: [Doc] -> Doc ppInitialiserList l = lbrace <+> commaSep l <+> rbrace  ppParamList :: [Doc] -> Doc-ppParamList = parens . commaSep+ppParamList = parens . indent 0 . commaSep  ppFunctionPrototype     :: Doc@@ -176,7 +213,7 @@     -> [Doc]     -> Doc ppSwitchStmt c body =-    nest 2 (+    nest indentWidth (         kwSwitch <+> parens c <+> lbrace <$>         vcat body     ) <$> rbrace@@ -193,7 +230,7 @@  ppCompoundStmt :: [Doc] -> Doc ppCompoundStmt body =-    nest 2 (+    nest indentWidth (         lbrace <$>         ppToplevel body     ) <$> rbrace@@ -208,13 +245,80 @@  ppLicenseDecl :: Lexeme Text -> [Doc] -> Doc ppLicenseDecl l cs =-    dullyellow $ ppCommentStyle Regular <+> text "SPDX-License-Identifier: " <> ppLexeme l <$>+    dullyellow $ ppCommentStart Regular <+> text "SPDX-License-Identifier: " <> ppLexeme l <$>     vcat (map dullyellow cs) <$>     dullyellow (text " */")  ppIntList :: [Lexeme Text] -> Doc ppIntList = parens . commaSep . map (dullred . ppLexeme) +ppMacroBody :: Doc -> Doc+ppMacroBody =+    vcat+    . map dullmagenta+    . punctuate (text " \\")+    . map text+    . List.splitOn "\n"+    . renderS+    . plain++ppVerbatimComment :: Doc -> Doc+ppVerbatimComment =+    vcat+    . map dullyellow+    . zipWith (<>) (empty : repeat (text " * "))+    . map text+    . List.splitOn "\n"+    . renderS+    . plain++ppCommentInfo :: Comment (Lexeme Text) -> Doc+ppCommentInfo = foldFix go+  where+  ppBody     = vcat . zipWith (<>) (        repeat (dullyellow (text " * "  )))+  ppIndented = vcat . zipWith (<>) (empty : repeat (dullyellow (text " *   ")))+  ppRef      = underline . cyan . ppLexeme+  ppAttr     = maybe empty (blue . ppLexeme)++  go :: CommentF (Lexeme Text) Doc -> Doc+  go = dullyellow . \case+    DocComment docs ->+        text "/**" <$>+        ppBody docs <$>+        dullyellow (text " */")+    DocWord w -> ppLexeme w+    DocSentence docs ending -> fillSep docs <> ppLexeme ending+    DocNewline -> empty++    DocParam attr name docs ->+        kwDocParam <> ppAttr attr <+> underline (cyan (ppLexeme name)) <+> ppIndented docs++    DocAttention docs   -> kwDocAttention  <+> ppIndented docs+    DocBrief docs       -> kwDocBrief      <+> ppIndented docs+    DocDeprecated docs  -> kwDocDeprecated <+> ppIndented docs+    DocReturn docs      -> kwDocReturn     <+> ppIndented docs+    DocRetval expr docs -> kwDocRetval     <+> dullred (ppLexeme expr) <+> ppIndented docs+    DocSee name docs    -> kwDocSee        <+> ppRef name <+> ppIndented docs+    DocRef name         -> kwDocRef        <+> ppRef name+    DocP name           -> kwDocP          <+> ppRef name+    DocExtends feat     -> kwDocExtends    <+> ppLexeme feat+    DocImplements feat  -> kwDocImplements <+> ppLexeme feat+    DocPrivate          -> kwDocPrivate++    DocParagraph docs -> ppIndented docs+    DocLine docs -> fillSep docs+    DocList l -> ppVerbatimComment $ vcat l+    DocOLItem num docs -> ppLexeme num <> char '.' <+> nest 3 (fillSep docs)+    DocULItem docs sublist -> char '-' <+> nest 2 (vsep $ fillSep docs : sublist)++    DocLParen doc -> lparen <> doc+    DocRParen doc -> doc <> rparen+    DocColon doc -> ppLexeme doc <> char ':'+    DocBinaryOp BopMinus l r -> l <>  char '-'      <>  r+    DocBinaryOp BopDiv   l r -> l <>  char '/'      <>  r+    DocAssignOp op       l r -> l <+> ppAssignOp op <+> r+    DocBinaryOp op       l r -> l <+> ppBinaryOp op <+> r+ ppNode :: Node (Lexeme Text) -> Doc ppNode = foldFix go   where@@ -231,12 +335,16 @@         text " * Copyright © " <> ppLexeme from <+>         ppCommentBody owner -    Comment style _ cs e ->-        ppComment style cs e+    Comment style _ cs end ->+        ppComment style cs end+    CommentSection start decls end ->+        start <$> line <> ppToplevel decls <> line <$> end     CommentSectionEnd cs ->         dullyellow $ ppLexeme cs     Commented c d ->         c <$> d+    CommentInfo docs ->+        ppCommentInfo docs      VarExpr var          -> ppLexeme var     LiteralExpr _ l      -> dullred $ ppLexeme l@@ -272,22 +380,22 @@      ExternC decls ->         dullmagenta (text "#ifdef __cplusplus") <$>-        text "extern \"C\" {" <$>+        kwExtern <+> dullred (text "\"C\"") <+> lbrace <$>         dullmagenta (text "#endif") <$>         line <>         ppToplevel decls <$>         line <>         dullmagenta (text "#ifdef __cplusplus") <$>-        text "}" <$>+        rbrace <$>         dullmagenta (text "#endif") +    Group decls -> vcat decls+     MacroParam l -> ppLexeme l      MacroBodyFunCall e -> e     MacroBodyStmt body ->-        if False-           then kwDo <+> body <+> kwWhile <+> text "(0)"-           else text "do { nothing(); } while (0)  // macros aren't supported well yet"+        kwDo <+> body <+> kwWhile <+> text "(0)"      PreprocScopedDefine def stmts undef ->         def <$> ppToplevel stmts <$> undef@@ -299,7 +407,7 @@     PreprocDefineConst name value ->         dullmagenta $ text "#define" <+> ppLexeme name <+> value     PreprocDefineMacro name params body ->-        dullmagenta $ text "#define" <+> ppLexeme name <> ppParamList params <+> body+        ppMacroBody $ text "#define" <+> ppLexeme name <> ppParamList params <+> body     PreprocUndef name ->         dullmagenta $ text "#undef" <+> ppLexeme name @@ -312,12 +420,12 @@         dullmagenta (text "#ifdef" <+> ppLexeme name) <$>         ppToplevel decls <>         elseBranch <$>-        dullmagenta (text "#endif")+        dullmagenta (text "#endif  //" <+> ppLexeme name)     PreprocIfndef name decls elseBranch ->         dullmagenta (text "#ifndef" <+> ppLexeme name) <$>         ppToplevel decls <>         elseBranch <$>-        dullmagenta (text "#endif")+        dullmagenta (text "#endif  //" <+> ppLexeme name)     PreprocElse [] -> empty     PreprocElse decls ->         linebreak <>@@ -329,6 +437,8 @@         ppToplevel decls <>         elseBranch +    AttrPrintf fmt ellipsis fun ->+        kwGnuPrintf <> ppIntList [fmt, ellipsis] <$> fun     CallbackDecl ty name ->         ppLexeme ty <+> ppLexeme name     FunctionPrototype ty name params ->@@ -345,12 +455,12 @@      AggregateDecl struct -> struct <> semi     Struct name members ->-        nest 2 (+        nest indentWidth (             kwStruct <+> ppLexeme name <+> lbrace <$>             vcat members         ) <$> rbrace     Union name members ->-        nest 2 (+        nest indentWidth (             kwUnion <+> ppLexeme name <+> lbrace <$>             vcat members         ) <$> rbrace@@ -370,17 +480,17 @@         ppLexeme name <+> equals <+> value <> comma      EnumConsts Nothing enums ->-        nest 2 (+        nest indentWidth (             kwEnum <+> lbrace <$>             vcat enums         ) <$> text "};"     EnumConsts (Just name) enums ->-        nest 2 (+        nest indentWidth (             kwEnum <+> ppLexeme name <+> lbrace <$>             vcat enums         ) <$> text "};"     EnumDecl name enums ty ->-        nest 2 (+        nest indentWidth (             kwTypedef <+> kwEnum <+> dullgreen (ppLexeme name) <+> lbrace <$>             vcat enums         ) <$> rbrace <+> dullgreen (ppLexeme ty) <> semi@@ -404,7 +514,7 @@     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+    Label l s                     -> indent (-99) (line <> ppLexeme l <> colon) <$> s     ExprStmt e                    -> e <> semi     Goto l                        -> kwGoto <+> ppLexeme l <> semi     Case e s                      -> kwCase <+> e <> colon <+> s@@ -422,3 +532,9 @@  showNode  :: Node (Lexeme Text) -> Text showNode = Text.pack . show . ppNode++renderS :: Doc -> String+renderS = flip displayS "" . renderSmart 1 120++render :: Doc -> Text+render = Text.pack . renderS

@@ -23,6 +23,7 @@     | KwEnum     | KwExtern     | KwFor+    | KwGnuPrintf     | KwGoto     | KwIf     | KwNonNull@@ -103,7 +104,9 @@     | PpUndef     | CmtBlock     | CmtCommand+    | CmtAttr     | CmtEndDocSection+    | CmtPrefix     | CmtIndent     | CmtStart     | CmtStartBlock@@ -115,10 +118,13 @@     | CmtWord     | CmtRef     | CmtEnd+    | IgnStart+    | IgnBody+    | IgnEnd -    | Error+    | ErrorToken     | Eof-    deriving (Show, Eq, Generic, Ord)+    deriving (Enum, Bounded, Ord, Eq, Show, Generic)  instance FromJSON LexemeClass instance ToJSON LexemeClass

@@ -12,6 +12,7 @@      , doFiles, doFile     , doNodes, doNode+    , doComment, doComments     , doLexemes, doLexeme     , doText @@ -20,9 +21,12 @@  import           Data.Fix              (Fix (..)) import           Data.Foldable         (traverse_)-import           Language.Cimple.Ast   (Node, NodeF (..))+import           Language.Cimple.Ast   (Comment, CommentF (..), Node,+                                        NodeF (..)) import           Language.Cimple.Lexer (Lexeme (..)) +{-# ANN module "HLint: ignore Reduce duplication" #-}+ class TraverseAst text a where     traverseFileAst         :: Applicative f@@ -38,18 +42,22 @@ traverseAst = flip traverseFileAst "<stdin>"  data AstActions f text = AstActions-    { doFiles   :: [(FilePath, [Node (Lexeme text)])] -> f () -> f ()-    , doFile    ::  (FilePath, [Node (Lexeme text)])  -> f () -> f ()-    , doNodes   :: FilePath -> [Node (Lexeme text)]   -> f () -> f ()-    , doNode    :: FilePath ->  Node (Lexeme text)    -> f () -> f ()-    , doLexemes :: FilePath ->       [Lexeme text]    -> f () -> f ()-    , doLexeme  :: FilePath ->        Lexeme text     -> f () -> f ()-    , doText    :: FilePath ->               text             -> f ()+    { doFiles    :: [(FilePath, [Node    (Lexeme text)])] -> f () -> f ()+    , doFile     ::  (FilePath, [Node    (Lexeme text)])  -> f () -> f ()+    , doNodes    :: FilePath -> [Node    (Lexeme text)]   -> f () -> f ()+    , doNode     :: FilePath ->  Node    (Lexeme text)    -> f () -> f ()+    , doComment  :: FilePath ->  Comment (Lexeme text)    -> f () -> f ()+    , doComments :: FilePath -> [Comment (Lexeme text)]   -> f () -> f ()+    , doLexemes  :: FilePath ->          [Lexeme text]    -> f () -> f ()+    , doLexeme   :: FilePath ->           Lexeme text     -> f () -> f ()+    , doText     :: FilePath ->                  text             -> f ()     }  instance TraverseAst text        a       => TraverseAst text (Maybe a) where-    traverseFileAst _ _ _ = pure ()+    traverseFileAst _ _ Nothing = pure ()+    traverseFileAst actions currentFile (Just x) =+        traverseFileAst actions currentFile x  astActions     :: Applicative f@@ -59,6 +67,8 @@     , doFile      = const id     , doNodes     = const $ const id     , doNode      = const $ const id+    , doComment   = const $ const id+    , doComments  = const $ const id     , doLexeme    = const $ const id     , doLexemes   = const $ const id     , doText      = const $ const $ pure ()@@ -75,6 +85,94 @@     traverseFileAst actions@AstActions{..} currentFile = doLexemes currentFile <*>         traverse_ (traverseFileAst actions currentFile) +instance TraverseAst text (Comment (Lexeme text)) where+    traverseFileAst+        :: forall f . Applicative f+        => AstActions f text+        -> FilePath+        -> Comment (Lexeme text)+        -> f ()+    traverseFileAst actions@AstActions{..} currentFile = doComment currentFile <*> \comment -> case unFix comment of+        DocComment docs ->+            recurse docs+        DocWord word ->+            recurse word+        DocSentence docs ending -> do+            _ <- recurse docs+            _ <- recurse ending+            pure ()+        DocNewline -> pure ()++        DocAttention docs ->+            recurse docs+        DocBrief docs ->+            recurse docs+        DocDeprecated docs ->+            recurse docs+        DocExtends feat ->+            recurse feat+        DocImplements feat ->+            recurse feat+        DocParam attr name docs -> do+            _ <- recurse attr+            _ <- recurse name+            _ <- recurse docs+            pure ()+        DocReturn docs ->+            recurse docs+        DocRetval expr docs -> do+            _ <- recurse expr+            _ <- recurse docs+            pure ()+        DocSee ref docs -> do+            _ <- recurse ref+            _ <- recurse docs+            pure ()++        DocPrivate -> pure ()++        DocParagraph docs ->+            recurse docs+        DocLine docs ->+            recurse docs+        DocList docs ->+            recurse docs+        DocOLItem docs sublist -> do+            _ <- recurse docs+            _ <- recurse sublist+            pure ()+        DocULItem docs sublist -> do+            _ <- recurse docs+            _ <- recurse sublist+            pure ()++        DocColon docs ->+            recurse docs+        DocRef doc ->+            recurse doc+        DocP doc ->+            recurse doc+        DocLParen docs ->+            recurse docs+        DocRParen docs ->+            recurse docs+        DocAssignOp _ lhs rhs -> do+            _ <- recurse lhs+            _ <- recurse rhs+            pure ()+        DocBinaryOp _ lhs rhs -> do+            _ <- recurse lhs+            _ <- recurse rhs+            pure ()++      where+        recurse :: TraverseAst text a => a -> f ()+        recurse = traverseFileAst actions currentFile++instance TraverseAst text [Comment (Lexeme text)] where+    traverseFileAst actions@AstActions{..} currentFile = doComments currentFile <*>+        traverse_ (traverseFileAst actions currentFile)+ instance TraverseAst text (Node (Lexeme text)) where     traverseFileAst         :: forall f . Applicative f@@ -151,6 +249,11 @@             _ <- recurse contents             _ <- recurse end             pure ()+        CommentSection start decls end -> do+            _ <- recurse start+            _ <- recurse decls+            _ <- recurse end+            pure ()         CommentSectionEnd comment -> do             _ <- recurse comment             pure ()@@ -158,8 +261,12 @@             _ <- recurse comment             _ <- recurse subject             pure ()+        CommentInfo comment ->+            recurse comment         ExternC decls ->             recurse decls+        Group decls ->+            recurse decls         CompoundStmt stmts ->             recurse stmts         Break ->@@ -327,6 +434,11 @@             recurse name         TyUserDefined name ->             recurse name+        AttrPrintf fmt ellipsis fun -> do+            _ <- recurse fmt+            _ <- recurse ellipsis+            _ <- recurse fun+            pure ()         FunctionDecl _scope proto ->             recurse proto         FunctionDefn _scope proto body -> do

@@ -1,15 +1,19 @@ { {-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Language.Cimple.TreeParser-    ( TreeParser-    , parseTranslationUnit-    , toEither-    ) where+{-# LANGUAGE ViewPatterns               #-}+module Language.Cimple.TreeParser (parseTranslationUnit) where -import           Data.Fix              (Fix (..))-import           Data.Text             (Text)-import           Language.Cimple.Ast   (CommentStyle (..), Node, NodeF (..))-import           Language.Cimple.Lexer (Lexeme)+import           Data.Fix                      (Fix (..))+import           Data.Maybe                    (maybeToList)+import           Data.Text                     (Text)+import qualified Data.Text                     as Text+import           Language.Cimple.Ast           (CommentStyle (..), Node,+                                                NodeF (..))+import           Language.Cimple.CommentParser (parseComment)+import           Language.Cimple.DescribeAst   (describeNode, sloc)+import           Language.Cimple.Lexer         (Lexeme (..))+import           Language.Cimple.ParseResult   (ParseResult)+import           Language.Cimple.Tokens        (LexemeClass (..)) }  %name parseTranslationUnit TranslationUnit@@ -18,21 +22,21 @@  %error {parseError} %errorhandlertype explist-%monad {TreeParser}-%tokentype {TextNode}+%monad {ParseResult}+%tokentype {NonTerm} %token-    ifndefDefine	{ Fix (PreprocIfndef _ body (Fix (PreprocElse []))) | isDefine body }-    ifdefDefine		{ Fix (PreprocIfdef _ body (Fix (PreprocElse []))) | isDefine body }-    ifDefine		{ Fix (PreprocIf _ body (Fix (PreprocElse []))) | isDefine body }--    ifndefInclude	{ Fix (PreprocIfndef{}) | isPreproc tk && hasInclude tk }-    ifdefInclude	{ Fix (PreprocIfdef{}) | isPreproc tk && hasInclude tk }-    ifInclude		{ Fix (PreprocIf{}) | isPreproc tk && hasInclude tk }+    ifndefDefine	{ Fix (PreprocIfndef _ (isDefine -> True) (Fix (PreprocElse []))) }+    ifdefDefine		{ Fix (PreprocIfdef _ (isDefine -> True) (Fix (PreprocElse []))) }+    ifDefine		{ Fix (PreprocIf _ (isDefine -> True) (Fix (PreprocElse []))) }      docComment		{ Fix (Comment Doxygen _ _ _) }      -- Preprocessor-    preprocInclude	{ Fix (PreprocInclude{}) }+    localIncludeBlock	{ (isIncludeBlock LitString -> True) }+    sysIncludeBlock	{ (isIncludeBlock LitSysInclude -> True) }+    localInclude	{ Fix (PreprocInclude (L _ LitString _)) }+    sysInclude		{ Fix (PreprocInclude (L _ LitSysInclude _)) }+     preprocDefine	{ Fix (PreprocDefine{}) }     preprocDefineConst	{ Fix (PreprocDefineConst{}) }     preprocDefineMacro	{ Fix (PreprocDefineMacro{}) }@@ -51,8 +55,9 @@     -- Comments     licenseDecl		{ Fix (LicenseDecl{}) }     copyrightDecl	{ Fix (CopyrightDecl{}) }-    comment		{ Fix (Comment{}) }+    commentSectionStart	{ Fix (Comment Section _ _ _) }     commentSectionEnd	{ Fix (CommentSectionEnd{}) }+    comment		{ Fix (Comment{}) }     commented		{ Fix (Commented{}) }     -- Namespace-like blocks     externC		{ Fix (ExternC{}) }@@ -122,65 +127,65 @@  %% -TranslationUnit :: { [TextNode] }+TranslationUnit :: { [NonTerm] } TranslationUnit :	licenseDecl docComment Header				{ [$1, Fix $ Commented $2 $3] }-|	licenseDecl docComment Source				{ $1 : mapHead (Fix . Commented $2)$3 }+|	licenseDecl docComment Source				{ $1 : mapHead (Fix . Commented $2) $3 } |	licenseDecl            Header				{ [$1, $2] } |	licenseDecl            Source				{ $1 : $2 } -Header :: { TextNode }+Header :: { NonTerm } Header :	preprocIfndef						{% recurse parseHeaderBody $1 } -HeaderBody :: { [TextNode] }+HeaderBody :: { [NonTerm] } HeaderBody-:	preprocDefine Includes Decls				{ $1 : reverse $2 ++ $3 }+:	preprocDefine Includes Decls				{ $1 : $2 ++ $3 } -Source :: { [TextNode] }+Source :: { [NonTerm] } Source-:	Features preprocInclude Includes Decls			{ $1 ++ [$2] ++ reverse $3 ++ $4 }+:	Features localInclude Includes Decls			{ maybeToList $1 ++ [$2] ++ $3 ++ $4 } -Features :: { [TextNode] }+Features :: { Maybe NonTerm } Features-:								{ [] }-|	Features IfDefine					{ $2 : $1 }+:								{ Nothing }+|	NonEmptyList(IfDefine)					{ Just $ Fix $ Group $1 } -IfDefine :: { TextNode }+IfDefine :: { NonTerm } IfDefine :	ifndefDefine						{ $1 } |	ifdefDefine						{ $1 } |	ifDefine						{ $1 } -Includes :: { [TextNode] }+Includes :: { [NonTerm] } Includes :								{ [] }-|	Includes Include					{ $2 : $1 }+|	NonEmptyList(SysInclude)				{ [Fix $ Group $1] }+|	NonEmptyList(LocalInclude)				{ [Fix $ Group $1] }+|	NonEmptyList(SysInclude) NonEmptyList(LocalInclude)	{ [Fix $ Group $1, Fix $ Group $2] } -Include :: { TextNode }-Include-:	preprocInclude						{ $1 }-|	ifndefInclude						{ $1 }-|	ifdefInclude						{ $1 }-|	ifInclude						{ $1 }+LocalInclude :: { NonTerm }+LocalInclude+:	localInclude						{ $1 }+|	localIncludeBlock					{ $1 } -Decls :: { [TextNode] }-Decls-:	DeclList						{ reverse $1 }+SysInclude :: { NonTerm }+SysInclude+:	sysInclude						{ $1 }+|	sysIncludeBlock						{ $1 } -DeclList :: { [TextNode] }-DeclList-:								{ [] }-|	DeclList Decl						{ $2 : $1 }+Decls :: { [NonTerm] }+Decls+:	List(Decl)						{ $1 } -Decl :: { TextNode }+Decl :: { NonTerm } Decl :	comment							{ $1 }-|	commentSectionEnd					{ $1 }+|	commentSectionStart Decls commentSectionEnd		{ Fix $ CommentSection $1 $2 $3 } |	CommentableDecl						{ $1 }-|	docComment CommentableDecl				{ Fix $ Commented $1 $2 }+|	docComment CommentableDecl				{% fmap (\c -> Fix $ Commented c $2) $ parseDocComment $1 } -CommentableDecl :: { TextNode }+CommentableDecl :: { NonTerm } CommentableDecl :	functionDecl						{ $1 } |	functionDefn						{ $1 }@@ -203,29 +208,40 @@ |	typedefFunction						{ $1 } |	IfDefine						{ $1 } -{-type TextLexeme = Lexeme Text-type TextNode = Node TextLexeme+List(x)+:								{ [] }+|	NonEmptyList(x)						{ $1 } -newtype TreeParser a = TreeParser { toEither :: Either String a }-    deriving (Functor, Applicative, Monad)+NonEmptyList(x)+:	NonEmptyList_(x)					{ reverse $1 } -instance MonadFail TreeParser where-    fail = TreeParser . Left+NonEmptyList_(x)+:	x							{ [$1] }+|	NonEmptyList_(x) x					{ $2 : $1 } +{+type TextLexeme = Lexeme Text+type NonTerm = Node TextLexeme + mapHead :: (a -> a) -> [a] -> [a] mapHead _ [] = [] mapHead f (x:xs) = f x : xs  -isDefine :: [TextNode] -> Bool+isDefine :: [NonTerm] -> Bool isDefine (Fix PreprocUndef{}:d)     = isDefine d isDefine [Fix PreprocDefine{}]      = True isDefine [Fix PreprocDefineConst{}] = True isDefine _                          = False -isPreproc :: TextNode -> Bool+isIncludeBlock :: LexemeClass -> NonTerm -> Bool+isIncludeBlock style tk@(Fix PreprocIfndef{}) = isPreproc tk && hasInclude style tk+isIncludeBlock style tk@(Fix PreprocIfdef{})  = isPreproc tk && hasInclude style tk+isIncludeBlock style tk@(Fix PreprocIf{})     = isPreproc tk && hasInclude style tk+isIncludeBlock _ _                            = False++isPreproc :: NonTerm -> Bool isPreproc (Fix PreprocInclude{})        = True isPreproc (Fix PreprocUndef{})          = True isPreproc (Fix PreprocDefine{})         = True@@ -236,29 +252,37 @@ isPreproc (Fix (PreprocElse ed))        = all isPreproc ed isPreproc _                             = False -hasInclude :: TextNode -> Bool-hasInclude (Fix PreprocInclude{})        = True-hasInclude (Fix (PreprocIf _ td ed))     = any hasInclude td || hasInclude ed-hasInclude (Fix (PreprocIfdef _ td ed))  = any hasInclude td || hasInclude ed-hasInclude (Fix (PreprocIfndef _ td ed)) = any hasInclude td || hasInclude ed-hasInclude (Fix (PreprocElse ed))        = any hasInclude ed-hasInclude _                             = False+hasInclude :: LexemeClass -> NonTerm -> Bool+hasInclude style (Fix (PreprocInclude (L _ c _))) = c == style+hasInclude style (Fix (PreprocIf _ td ed))        = any (hasInclude style) td || (hasInclude style) ed+hasInclude style (Fix (PreprocIfdef _ td ed))     = any (hasInclude style) td || (hasInclude style) ed+hasInclude style (Fix (PreprocIfndef _ td ed))    = any (hasInclude style) td || (hasInclude style) ed+hasInclude style (Fix (PreprocElse ed))           = any (hasInclude style) ed+hasInclude _ _                                    = False  -recurse :: ([TextNode] -> TreeParser [TextNode]) -> TextNode -> TreeParser TextNode+recurse :: ([NonTerm] -> ParseResult [NonTerm]) -> NonTerm -> ParseResult NonTerm recurse f (Fix (ExternC ds))          = Fix <$> (ExternC <$> f ds)-recurse f (Fix (PreprocIf c t e))     = Fix <$> (PreprocIf c <$> f t <*> recurse f e)-recurse f (Fix (PreprocIfdef c t e))  = Fix <$> (PreprocIfdef c <$> f t <*> recurse f e)+recurse f (Fix (PreprocIf     c t e)) = Fix <$> (PreprocIf     c <$> f t <*> recurse f e)+recurse f (Fix (PreprocIfdef  c t e)) = Fix <$> (PreprocIfdef  c <$> f t <*> recurse f e) recurse f (Fix (PreprocIfndef c t e)) = Fix <$> (PreprocIfndef c <$> f t <*> recurse f e) recurse f (Fix (PreprocIfndef c t e)) = Fix <$> (PreprocIfndef c <$> f t <*> recurse f e)-recurse f (Fix (PreprocElif c t e))   = Fix <$> (PreprocElif c <$> f t <*> recurse f e)-recurse f (Fix (PreprocElse []))      = return $ Fix $ PreprocElse []-recurse f (Fix (PreprocElse e))       = Fix <$> (PreprocElse <$> f e)+recurse f (Fix (PreprocElif   c t e)) = Fix <$> (PreprocElif   c <$> f t <*> recurse f e)+recurse f (Fix (PreprocElse      [])) = Fix <$> pure (PreprocElse [])+recurse f (Fix (PreprocElse       e)) = Fix <$> (PreprocElse     <$>                 f e) recurse _ ns                          = fail $ "TreeParser.recurse: " <> show ns +parseDocComment :: NonTerm -> ParseResult NonTerm+parseDocComment (Fix (Comment Doxygen start body end)) =+    Fix . CommentInfo <$> parseComment (start : body ++ [end])+parseDocComment n = return n -parseError :: ([TextNode], [String]) -> TreeParser a-parseError ([], options)  = fail $ "end of file; expected one of " <> show options-parseError (n:_, [])      = fail $ show n <> "; expected end of file"-parseError (n:_, options) = fail $ show n <> "; expected one of " <> show options+failAt :: NonTerm -> String -> ParseResult a+failAt n msg =+    fail $ Text.unpack (sloc "" n) <> ": unexpected " <> describeNode n <> msg++parseError :: ([NonTerm], [String]) -> ParseResult a+parseError ([], options)  = fail $ " end of file; expected one of " <> show options+parseError (n:_, [])      = failAt n "; expected end of file"+parseError (n:_, options) = failAt n $ "; expected one of " <> show options }

@@ -53,4 +53,4 @@         it "does not support multiple declarators per declaration" $ do             let ast = parseText "int main() { int a, b; }"             ast `shouldBe` Left-                "1:19: Parse error near PctComma: \",\"; expected one of [\"'='\",\"';'\"]"+                ":1:19: Parse error near PctComma: \",\"; expected one of [\"'='\",\"';'\"]"

@@ -3,16 +3,15 @@ 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           Language.Cimple.Pretty (plain, ppTranslationUnit, render) import           System.Environment     (getArgs)   format :: Bool -> [Node (Lexeme Text)] -> Text-format color = Text.pack . show . maybePlain . ppTranslationUnit+format color = render . maybePlain . ppTranslationUnit   where     maybePlain = if color then id else plain @@ -32,11 +31,11 @@     putStrLn $ "Processing " ++ source     ast <- parseFile source     case ast of-        Left err -> fail err+        Left err -> putStrLn err >> fail "aborting after parse error"         Right (_, ok) ->-            if "--no-reparse" `elem` flags-               then BS.putStr . Text.encodeUtf8 . format True $ ok-               else reparseText $ format False ok+            if "--reparse" `elem` flags+               then reparseText $ format False ok+               else BS.putStr . Text.encodeUtf8 . format True $ ok   main :: IO ()