cimple 0.0.27 → 0.0.28

raw patch · 21 files changed

+1534/−234 lines, 21 filesdep +optparse-applicativePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: optparse-applicative

API changes (from Hackage documentation)

Files

• cimple.cabal +9/−5
• src/Language/Cimple.hs +25/−11
• src/Language/Cimple/Ast.hs +125/−3
• src/Language/Cimple/DescribeAst.hs +2/−45
• src/Language/Cimple/Flatten.hs +4/−1
• src/Language/Cimple/IO.hs +38/−20
• src/Language/Cimple/Lexer.x +70/−5
• src/Language/Cimple/MapAst.hs +2/−6
• src/Language/Cimple/Parser.y +46/−20
• src/Language/Cimple/Parser/Error.hs +17/−0
• src/Language/Cimple/Parser/Error/Pretty.hs +198/−0
• src/Language/Cimple/Pretty.hs +9/−8
• src/Language/Cimple/Tokens.hs +14/−4
• src/Language/Cimple/TraverseAst.hs +1/−7
• test/Language/Cimple/AstSpec.hs +152/−4
• test/Language/Cimple/DescribeAstSpec.hs +0/−63
• test/Language/Cimple/ParserSpec.hs +155/−10
• test/Language/Cimple/PrettyCommentSpec.hs +617/−0
• test/Language/Cimple/PrettySpec.hs +7/−1
• test/Language/CimpleSpec.hs +2/−9
• tools/cimplefmt.hs +41/−12

@@ -1,5 +1,5 @@ name:          cimple-version:       0.0.27+version:       0.0.28 synopsis:      Simple C-like programming language homepage:      https://toktok.github.io/ license:       GPL-3@@ -40,8 +40,10 @@     Language.Cimple.Flatten     Language.Cimple.Graph     Language.Cimple.Lexer-    Language.Cimple.Parser     Language.Cimple.ParseResult+    Language.Cimple.Parser+    Language.Cimple.Parser.Error+    Language.Cimple.Parser.Error.Pretty     Language.Cimple.PrettyColor     Language.Cimple.PrettyComment     Language.Cimple.PrettyCommon@@ -51,7 +53,8 @@     Language.Cimple.TreeParser    build-depends:-      aeson+      QuickCheck+    , aeson     , array     , base                 <5     , bytestring@@ -77,6 +80,7 @@       base        <5     , bytestring     , cimple+    , optparse-applicative     , text  executable dump-ast@@ -116,12 +120,12 @@   hs-source-dirs:     test   main-is:            testsuite.hs   other-modules:-    Language.CimpleSpec     Language.Cimple.AstSpec     Language.Cimple.CommentParserSpec-    Language.Cimple.DescribeAstSpec     Language.Cimple.ParserSpec+    Language.Cimple.PrettyCommentSpec     Language.Cimple.PrettySpec+    Language.CimpleSpec    ghc-options:        -Wall -Wno-unused-imports   build-tool-depends: hspec-discover:hspec-discover

@@ -3,21 +3,24 @@     , DefaultActions     , defaultActions     , removeSloc+    , elideGroups     , getParamNameFromNode     ) where -import           Control.Monad.State.Strict  (State)-import qualified Control.Monad.State.Strict  as State-import           Data.Fix                    (Fix (..))-import           Data.Text                   (Text)+import           Control.Monad.State.Strict          (State)+import qualified Control.Monad.State.Strict          as State+import           Data.Fix                            (Fix (..))+import           Data.Text                           (Text) -import           Language.Cimple.Annot       as X-import           Language.Cimple.Ast         as X-import           Language.Cimple.DescribeAst as X-import           Language.Cimple.Lexer       as X-import           Language.Cimple.MapAst      as X-import           Language.Cimple.Parser      as X-import           Language.Cimple.Tokens      as X+import           Language.Cimple.Annot               as X+import           Language.Cimple.Ast                 as X+import           Language.Cimple.DescribeAst         as X+import           Language.Cimple.Flatten             as X+import           Language.Cimple.Lexer               as X+import           Language.Cimple.MapAst              as X+import           Language.Cimple.Parser              as X+import           Language.Cimple.Parser.Error.Pretty as X+import           Language.Cimple.Tokens              as X  type DefaultActions a = X.IdentityActions (State a) Text @@ -28,6 +31,17 @@ removeSloc =     flip State.evalState () . mapAst defaultActions         { doLexeme = \_ (L _ c t) _ -> pure $ L (AlexPn 0 0 0) c t }++elideGroups :: Node (Lexeme Text) -> Node (Lexeme Text)+elideGroups =+    flip State.evalState () . mapAst defaultActions+        { doNodes = \_ _ m_nodes -> do+            nodes <- m_nodes+            return $ concatMap flatten nodes+        }+  where+    flatten (Fix (Group ns)) = concatMap flatten ns+    flatten n                = [n]  getParamNameFromNode :: Node (Lexeme Text) -> Maybe Text getParamNameFromNode (Fix (VarDecl _ (L _ _ name) _)) = Just name

@@ -19,6 +19,7 @@  import           Data.Aeson                   (FromJSON, FromJSON1, ToJSON,                                                ToJSON1)+import           Data.Bifunctor               (Bifunctor (..)) import           Data.Fix                     (Fix (..)) import           Data.Functor.Classes         (Eq1, Ord1, Read1, Show1) import           Data.Functor.Classes.Generic (FunctorClassesDefault (..))@@ -79,8 +80,7 @@     | VLA a lexeme a     | VarDeclStmt a (Maybe a)     | VarDecl a lexeme [a]-    | DeclSpecArray (Maybe a)-    | ArrayDim Nullability a+    | DeclSpecArray Nullability (Maybe a)     -- Expressions     | InitialiserList [a]     | UnaryExpr UnaryOp a@@ -89,7 +89,6 @@     | AssignExpr a AssignOp a     | ParenExpr a     | CastExpr a a-    | CompoundExpr a a -- DEPRECATED     | CompoundLiteral a a     | SizeofExpr a     | SizeofType a@@ -138,6 +137,101 @@     deriving (Show, Read, Eq, Ord, Generic, Generic1, Functor, Foldable, Traversable)     deriving (Show1, Read1, Eq1, Ord1) via FunctorClassesDefault (NodeF lexeme) +instance Bifunctor NodeF where+    bimap f g n = case n of+        PreprocInclude l -> PreprocInclude (f l)+        PreprocDefine l -> PreprocDefine (f l)+        PreprocDefineConst l a -> PreprocDefineConst (f l) (g a)+        PreprocDefineMacro l as a -> PreprocDefineMacro (f l) (map g as) (g a)+        PreprocIf a as a' -> PreprocIf (g a) (map g as) (g a')+        PreprocIfdef l as a -> PreprocIfdef (f l) (map g as) (g a)+        PreprocIfndef l as a -> PreprocIfndef (f l) (map g as) (g a)+        PreprocElse as -> PreprocElse (map g as)+        PreprocElif a as a' -> PreprocElif (g a) (map g as) (g a')+        PreprocUndef l -> PreprocUndef (f l)+        PreprocDefined l -> PreprocDefined (f l)+        PreprocScopedDefine a as a' -> PreprocScopedDefine (g a) (map g as) (g a')+        MacroBodyStmt a -> MacroBodyStmt (g a)+        MacroBodyFunCall a -> MacroBodyFunCall (g a)+        MacroParam l -> MacroParam (f l)+        StaticAssert a l -> StaticAssert (g a) (f l)+        LicenseDecl l as -> LicenseDecl (f l) (map g as)+        CopyrightDecl l ml ls -> CopyrightDecl (f l) (fmap f ml) (map f ls)+        Comment s l ls l' -> Comment s (f l) (map f ls) (f l')+        CommentSection a as a' -> CommentSection (g a) (map g as) (g a')+        CommentSectionEnd l -> CommentSectionEnd (f l)+        Commented a a' -> Commented (g a) (g a')+        CommentInfo c -> CommentInfo (mapCommentLexeme f c)+        ExternC as -> ExternC (map g as)+        Group as -> Group (map g as)+        CompoundStmt as -> CompoundStmt (map g as)+        Break -> Break+        Goto l -> Goto (f l)+        Continue -> Continue+        Return ma -> Return (fmap g ma)+        SwitchStmt a as -> SwitchStmt (g a) (map g as)+        IfStmt a a' ma'' -> IfStmt (g a) (g a') (fmap g ma'')+        ForStmt a a' a'' a''' -> ForStmt (g a) (g a') (g a'') (g a''')+        WhileStmt a as -> WhileStmt (g a) (g as)+        DoWhileStmt a a' -> DoWhileStmt (g a) (g a')+        Case a a' -> Case (g a) (g a')+        Default a -> Default (g a)+        Label l a -> Label (f l) (g a)+        ExprStmt a -> ExprStmt (g a)+        VLA a l a' -> VLA (g a) (f l) (g a')+        VarDeclStmt a ma -> VarDeclStmt (g a) (fmap g ma)+        VarDecl a l as -> VarDecl (g a) (f l) (map g as)+        DeclSpecArray nullability ma -> DeclSpecArray nullability (fmap g ma)+        InitialiserList as -> InitialiserList (map g as)+        UnaryExpr u a -> UnaryExpr u (g a)+        BinaryExpr a b a' -> BinaryExpr (g a) b (g a')+        TernaryExpr a a' a'' -> TernaryExpr (g a) (g a') (g a'')+        AssignExpr a as a' -> AssignExpr (g a) as (g a')+        ParenExpr a -> ParenExpr (g a)+        CastExpr a a' -> CastExpr (g a) (g a')+        CompoundLiteral a a' -> CompoundLiteral (g a) (g a')+        SizeofExpr a -> SizeofExpr (g a)+        SizeofType a -> SizeofType (g a)+        LiteralExpr t l -> LiteralExpr t (f l)+        VarExpr l -> VarExpr (f l)+        MemberAccess a l -> MemberAccess (g a) (f l)+        PointerAccess a l -> PointerAccess (g a) (f l)+        ArrayAccess a a' -> ArrayAccess (g a) (g a')+        FunctionCall a as -> FunctionCall (g a) (map g as)+        CommentExpr a a' -> CommentExpr (g a) (g a')+        EnumConsts ml as -> EnumConsts (fmap f ml) (map g as)+        EnumDecl l as l' -> EnumDecl (f l) (map g as) (f l')+        Enumerator l ma -> Enumerator (f l) (fmap g ma)+        AggregateDecl a -> AggregateDecl (g a)+        Typedef a l -> Typedef (g a) (f l)+        TypedefFunction a -> TypedefFunction (g a)+        Struct l as -> Struct (f l) (map g as)+        Union l as -> Union (f l) (map g as)+        MemberDecl a ml -> MemberDecl (g a) (fmap f ml)+        TyBitwise a -> TyBitwise (g a)+        TyForce a -> TyForce (g a)+        TyConst a -> TyConst (g a)+        TyOwner a -> TyOwner (g a)+        TyNonnull a -> TyNonnull (g a)+        TyNullable a -> TyNullable (g a)+        TyPointer a -> TyPointer (g a)+        TyStruct l -> TyStruct (f l)+        TyUnion l -> TyUnion (f l)+        TyFunc l -> TyFunc (f l)+        TyStd l -> TyStd (f l)+        TyUserDefined l -> TyUserDefined (f l)+        AttrPrintf l l' a -> AttrPrintf (f l) (f l') (g a)+        FunctionDecl s a -> FunctionDecl s (g a)+        FunctionDefn s a a' -> FunctionDefn s (g a) (g a')+        FunctionPrototype a l as -> FunctionPrototype (g a) (f l) (map g as)+        CallbackDecl l l' -> CallbackDecl (f l) (f l')+        Ellipsis -> Ellipsis+        NonNull ls ls' a -> NonNull (map f ls) (map f ls') (g a)+        NonNullParam a -> NonNullParam (g a)+        NullableParam a -> NullableParam (g a)+        ConstDecl a l -> ConstDecl (g a) (f l)+        ConstDefn s a l a' -> ConstDefn s (g a) (f l) (g a')+ type Node lexeme = Fix (NodeF lexeme)  instance FromJSON lexeme => FromJSON1 (NodeF lexeme)@@ -173,6 +267,33 @@     deriving (Show, Read, Eq, Ord, Generic, Generic1, Functor, Foldable, Traversable)     deriving (Show1, Read1, Eq1, Ord1) via FunctorClassesDefault (CommentF lexeme) +instance Bifunctor CommentF where+    bimap f g n = case n of+        DocComment as           -> DocComment (map g as)+        DocAttention            -> DocAttention+        DocBrief                -> DocBrief+        DocDeprecated           -> DocDeprecated+        DocExtends l            -> DocExtends (f l)+        DocFile                 -> DocFile+        DocImplements l         -> DocImplements (f l)+        DocNote                 -> DocNote+        DocParam ml l           -> DocParam (fmap f ml) (f l)+        DocReturn               -> DocReturn+        DocRetval               -> DocRetval+        DocSection l            -> DocSection (f l)+        DocSecurityRank l ml l' -> DocSecurityRank (f l) (fmap f ml) (f l')+        DocSee l                -> DocSee (f l)+        DocSubsection l         -> DocSubsection (f l)+        DocPrivate              -> DocPrivate+        DocLine as              -> DocLine (map g as)+        DocCode l as l'         -> DocCode (f l) (map g as) (f l')+        DocWord l               -> DocWord (f l)+        DocRef l                -> DocRef (f l)+        DocP l                  -> DocP (f l)++mapCommentLexeme :: (l -> l') -> Comment l -> Comment l'+mapCommentLexeme f (Fix n) = Fix $ bimap f (mapCommentLexeme f) n+ type Comment lexeme = Fix (CommentF lexeme)  instance FromJSON lexeme => FromJSON1 (CommentF lexeme)@@ -236,6 +357,7 @@ data LiteralType     = Char     | Int+    | Float     | Bool     | String     | ConstId

@@ -6,18 +6,15 @@     , describeLexeme     , describeNode     , getLoc-    , parseError     ) where  import           Data.Fix                (Fix (..), foldFix, unFix)-import           Data.List               (isPrefixOf, (\\))-import qualified Data.List               as List 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   (Alex, AlexPosn (..), Lexeme (..),-                                          alexError, lexemeLine)+import           Language.Cimple.Lexer   (AlexPosn (..), Lexeme (..),+                                          lexemeLine) import           Language.Cimple.Tokens  (LexemeClass (..))  @@ -146,43 +143,3 @@  describeLexeme :: Show a => Lexeme a -> String describeLexeme (L _ c s) = maybe "" (<> ": ") (describeLexemeClass c) <> show s--describeExpected :: [String] -> String-describeExpected [] = "end of file"-describeExpected ["ID_VAR"] = "variable name"-describeExpected [option] = option-describeExpected options-    | wants ["break", "const", "continue", "ID_CONST", "VLA"] = "statement or declaration"-    | wants ["ID_FUNC_TYPE", "non_null", "static", "'#include'"] = "top-level declaration or definition"-    | options == ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "struct", "union", "void"] = "top-level type specifier"-    | options == ["ID_STD_TYPE", "ID_SUE_TYPE", "struct", "union", "void"] = "type specifier"-    | options == ["ID_STD_TYPE", "ID_SUE_TYPE", "bitwise", "const", "force", "struct", "union", "void"] = "type specifier"-    | options == ["ID_CONST", "ID_VAR", "LIT_CHAR", "LIT_FALSE", "LIT_INTEGER", "'{'"] = "constant or literal"-    | ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "ID_VAR"] `isPrefixOf` options = "type specifier or variable name"-    | ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "bitwise", "const"] `isPrefixOf` options = "type specifier"-    | ["ID_CONST", "sizeof", "LIT_CHAR", "LIT_FALSE", "LIT_TRUE", "LIT_INTEGER"] `isPrefixOf` options = "constant expression"-    | ["ID_CONST", "ID_SUE_TYPE", "'/*'"] `isPrefixOf` options = "enumerator, type name, or comment"-    | wants ["'defined'"] = "preprocessor constant expression"-    | wants ["'&'", "'&&'", "'*'", "'=='", "';'"] = "operator or end of statement"-    | wants ["'&'", "'&&'", "'*'", "'^'", "'!='"] = "operator"-    | wants ["ID_CONST", "ID_VAR", "sizeof", "LIT_CHAR", "'--'", "'&'", "'*'"] = "expression"-    | ["ID_CONST", "ID_STD_TYPE", "ID_SUE_TYPE", "ID_VAR", "const", "sizeof"] `isPrefixOf` options = "expression or type specifier"-    | ["ID_CONST", "ID_STD_TYPE", "ID_SUE_TYPE", "const", "sizeof"] `isPrefixOf` options = "constant expression or type specifier"-    | ["'&='", "'->'", "'*='"] `isPrefixOf` options = "assignment or member/array access"-    | wants ["CMT_WORD"] = "comment contents"--    | length options == 2 = commaOr options-    | otherwise           = "one of " <> commaOr options-  where-    wants xs = null (xs \\ options)--commaOr :: [String] -> String-commaOr = go . reverse-  where-    go []     = ""-    go (x:xs) = List.intercalate ", " (reverse xs) <> " or " <> x--parseError :: Show text => (Lexeme text, [String]) -> Alex a-parseError (l@(L (AlexPn _ line col) _ _), options) =-    alexError $ ":" <> show line <> ":" <> show col <> ": Parse error near " <> describeLexeme l-        <> "; expected " <> describeExpected options

@@ -4,7 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Strict                #-} {-# LANGUAGE TypeOperators         #-}-module Language.Cimple.Flatten (lexemes) where+module Language.Cimple.Flatten (Concats (..), lexemes) where  import           Data.Fix            (Fix (..)) import           Data.Maybe          (maybeToList)@@ -45,6 +45,9 @@ instance GenConcatsFlatten CommentStyle a where gconcatsFlatten = const [] instance GenConcatsFlatten LiteralType  a where gconcatsFlatten = const [] instance GenConcatsFlatten Nullability  a where gconcatsFlatten = const []++instance (GenConcatsFlatten b a, GenConcatsFlatten c a) => GenConcatsFlatten (b, c) a where+    gconcatsFlatten (x, y) = gconcatsFlatten x ++ gconcatsFlatten y  instance GenConcatsFlatten b a => GenConcatsFlatten (Maybe b) a where     gconcatsFlatten = gconcatsFlatten . maybeToList

@@ -6,26 +6,33 @@     , parseProgram     , parseStmt     , parseText+    , parseUnit     ) where -import           Control.Monad                   ((>=>))-import qualified Control.Monad.Parallel          as P-import           Control.Monad.State.Strict      (State, evalState, get, put)-import qualified Data.ByteString.Lazy            as LBS-import           Data.Map.Strict                 (Map)-import qualified Data.Map.Strict                 as Map-import           Data.Text                       (Text)-import qualified Data.Text.Encoding              as Text-import           Language.Cimple.Ast             (Node)-import           Language.Cimple.Lexer           (Alex, Lexeme, runAlex)-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)-import qualified Language.Cimple.TreeParser      as TreeParser+import           Control.Monad                       ((>=>))+import qualified Control.Monad.Parallel              as P+import           Control.Monad.State.Strict          (State, evalState, get,+                                                      put)+import           Data.Aeson                          (decode)+import qualified Data.ByteString.Lazy                as LBS+import qualified Data.ByteString.Lazy.Char8          as LBSC+import           Data.List                           (isPrefixOf)+import           Data.Map.Strict                     (Map)+import qualified Data.Map.Strict                     as Map+import           Data.Text                           (Text)+import qualified Data.Text.Encoding                  as Text+import           Language.Cimple.Ast                 (Node)+import           Language.Cimple.Lexer               (Alex, Lexeme, ParseError,+                                                      runAlex)+import           Language.Cimple.MapAst              (TextActions, mapAst,+                                                      textActions)+import qualified Language.Cimple.Parser              as Parser+import           Language.Cimple.Parser.Error.Pretty (formatParseError)+import qualified Language.Cimple.ParseResult         as ParseResult+import           Language.Cimple.Program             (Program)+import qualified Language.Cimple.Program             as Program+import           Language.Cimple.TranslationUnit     (TranslationUnit)+import qualified Language.Cimple.TreeParser          as TreeParser  type TextNode = Node (Lexeme Text) @@ -44,8 +51,15 @@                 return text  +deserializeAndFormat :: String -> String+deserializeAndFormat err =+    case decode (LBSC.pack err) of+        Just p  -> formatParseError p+        Nothing -> err++ runText :: Alex a -> Text -> Either String a-runText f = flip runAlex f . LBS.fromStrict . Text.encodeUtf8+runText f = either (Left . deserializeAndFormat) Right . flip runAlex f . LBS.fromStrict . Text.encodeUtf8  parseExpr :: Text -> Either String TextNode parseExpr = runText Parser.parseExpr@@ -57,10 +71,14 @@ parseText = fmap cacheText . runText Parser.parseTranslationUnit >=> ParseResult.toEither . TreeParser.parseTranslationUnit  parseBytes :: LBS.ByteString -> Either String [TextNode]-parseBytes = flip runAlex Parser.parseTranslationUnit+parseBytes = either (Left . deserializeAndFormat) Right . flip runAlex Parser.parseTranslationUnit  parseBytesPedantic :: LBS.ByteString -> Either String [TextNode] parseBytesPedantic = parseBytes >=> ParseResult.toEither . TreeParser.parseTranslationUnit+++parseUnit :: Bool -> LBS.ByteString -> Either String [TextNode]+parseUnit pedantic = if pedantic then parseBytesPedantic else parseBytes   parseFile :: FilePath -> IO (Either String (TranslationUnit Text))

@@ -17,20 +17,31 @@     , lexemeText     , lexemeLine     , runAlex+    , pushContext+    , popContext+    , getContext+    , Context (..)+    , ParseError (..)     ) where -import           Data.Aeson             (FromJSON, ToJSON)+import           Data.Aeson             (FromJSON, FromJSONKey (..),+                                         FromJSONKeyFunction (..), ToJSON,+                                         ToJSONKey (..), ToJSONKeyFunction (..),+                                         toEncoding, toJSON)+import qualified Data.Aeson.Types       as Aeson import qualified Data.ByteString        as BS import qualified Data.ByteString.Lazy   as LBS+import           Data.Hashable          (Hashable (..)) import           Data.Text              (Text) import qualified Data.Text              as Text import qualified Data.Text.Encoding     as Text import           GHC.Generics           (Generic)+import           Language.Cimple.Ast    (Node) import           Language.Cimple.Tokens (LexemeClass (..))-import           Data.Hashable (Hashable(..))+import           Test.QuickCheck        (Arbitrary (..)) } -%wrapper "monad-bytestring"+%wrapper "monadUserState-bytestring"  tokens :- @@ -114,6 +125,9 @@ <0>		"msgpack_zbuffer"			{ mkL IdSueType } <0>		"msgpack_zone"				{ mkL IdSueType } +-- Sodium types.+<0>		"crypto_generichash_blake2b_state"	{ mkL IdSueType }+ -- Sodium constants. <0,ppSC>	"crypto_"[a-z0-9_]+[A-Z][A-Z0-9_]*	{ mkL IdConst } @@ -160,6 +174,7 @@ <0,ppSC>	"tox_"?"force"				{ mkL KwForce } <0,ppSC>	"tox_"?"owner"				{ mkL KwOwner } <0,ppSC>	"_Owner"				{ mkL KwOwner }+<0,ppSC>	"_Owned"				{ mkL KwOwner } <0,ppSC>	"break"					{ mkL KwBreak } <0,ppSC>	"case"					{ mkL KwCase } <0,ppSC>	"const"					{ mkL KwConst }@@ -210,7 +225,7 @@ <0,ppSC>	"cmp_"("reader"|"writer"|"skipper")	{ mkL IdFuncType } <0,ppSC>	[a-z][A-Za-z0-9_]*			{ mkL IdVar } <0,ppSC,cmtSC>	[0-9]+[LU]*				{ mkL LitInteger }-<0,ppSC,cmtSC>	[0-9]+"."[0-9]+[Ff]?			{ mkL LitInteger }+<0,ppSC,cmtSC>	[0-9]+"."[0-9]+[Ff]?			{ mkL LitFloat } <0,ppSC>	0x[0-9a-fA-F]+[LU]*			{ mkL LitInteger } <0,ppSC,cmtSC>	"="					{ mkL PctEq } <0,ppSC,cmtSC>	"=="					{ mkL PctEqEq }@@ -309,15 +324,26 @@ { deriving instance Generic AlexPosn instance FromJSON AlexPosn+instance FromJSONKey AlexPosn where fromJSONKey = Aeson.FromJSONKeyText (read . Text.unpack) instance ToJSON AlexPosn+instance ToJSONKey AlexPosn where toJSONKey = Aeson.toJSONKeyText (Text.pack . show) instance Hashable AlexPosn+deriving instance Read AlexPosn +instance Arbitrary AlexPosn where+    arbitrary = AlexPn <$> arbitrary <*> arbitrary <*> arbitrary+ data Lexeme text = L AlexPosn LexemeClass text-    deriving (Eq, Show, Generic, Functor, Foldable, Traversable, Ord)+    deriving (Eq, Show, Read, Generic, Functor, Foldable, Traversable, Ord) +instance Arbitrary text => Arbitrary (Lexeme text) where+    arbitrary = L <$> arbitrary <*> arbitrary <*> arbitrary++ instance FromJSON text => FromJSON (Lexeme text) instance ToJSON text => ToJSON (Lexeme text) instance Hashable text => Hashable (Lexeme text) where+    hashWithSalt s (L p c t) = s `hashWithSalt` p `hashWithSalt` c `hashWithSalt` t  mkL :: LexemeClass -> AlexInput -> Int64 -> Alex (Lexeme Text) mkL c (p, _, str, _) len = pure $ L p c (piece str)@@ -341,6 +367,45 @@  alexEOF :: Alex (Lexeme Text) alexEOF = return (L (AlexPn 0 0 0) Eof Text.empty)++data Context+    = Context String+    | ContextLexeme String (Lexeme Text)+    | ContextNode String (Node (Lexeme Text))+    deriving (Eq, Show, Read, Generic)++instance FromJSON Context+instance ToJSON Context+instance Hashable Context++data AlexUserState = AlexUserState { alex_context :: [Context] }+alexInitUserState = AlexUserState []++data ParseError = ParseError+    { errorPosn     :: AlexPosn+    , errorContext  :: [Context]+    , errorExpected :: [String]+    , errorLexeme   :: Lexeme Text+    } deriving (Eq, Show, Read, Generic)++instance FromJSON ParseError+instance ToJSON ParseError+instance Hashable ParseError++pushContext :: Context -> Alex ()+pushContext ctx = Alex $ \s ->+    let us = alex_ust s+        us' = us { alex_context = ctx : alex_context us }+    in Right (s { alex_ust = us' }, ())++popContext :: Alex ()+popContext = Alex $ \s ->+    let us = alex_ust s+        us' = us { alex_context = case alex_context us of [] -> []; (_:cs) -> cs }+    in Right (s { alex_ust = us' }, ())++getContext :: Alex [Context]+getContext = Alex $ \s -> Right (s, alex_context (alex_ust s))  alexScanTokens :: LBS.ByteString -> Either String [Lexeme Text] alexScanTokens str =

@@ -253,10 +253,8 @@             Fix <$> (VarDeclStmt <$> recurse decl <*> recurse ini)         VarDecl ty name arrs ->             Fix <$> (VarDecl <$> recurse ty <*> recurse name <*> recurse arrs)-        DeclSpecArray size ->-            Fix <$> (DeclSpecArray <$> recurse size)-        ArrayDim nullability size ->-            Fix <$> (ArrayDim nullability <$> recurse size)+        DeclSpecArray nullability size ->+            Fix <$> (DeclSpecArray nullability <$> recurse size)         InitialiserList values ->             Fix <$> (InitialiserList <$> recurse values)         UnaryExpr op expr ->@@ -271,8 +269,6 @@             Fix <$> (ParenExpr <$> recurse expr)         CastExpr ty expr ->             Fix <$> (CastExpr <$> recurse ty <*> recurse expr)-        CompoundExpr ty expr -> -- DEPRECATED-            Fix <$> (CompoundExpr <$> recurse ty <*> recurse expr)         CompoundLiteral ty expr ->             Fix <$> (CompoundLiteral <$> recurse ty <*> recurse expr)         SizeofExpr expr ->

@@ -6,6 +6,7 @@     ( parseExpr     , parseStmt     , parseTranslationUnit+    , preprocessorEnabled     , source     ) where @@ -19,7 +20,7 @@                                               LiteralType (..), Node,                                               NodeF (..), Nullability (..),                                               Scope (..), UnaryOp (..))-import           Language.Cimple.DescribeAst (parseError)+import           Language.Cimple.Parser.Error (parseError) import           Language.Cimple.Lexer       (Alex, AlexPosn (..), Lexeme (..),                                               alexError, alexMonadScan) import           Language.Cimple.Tokens      (LexemeClass (..))@@ -73,6 +74,7 @@     void			{ L _ KwVoid			_ }     while			{ L _ KwWhile			_ }     LIT_CHAR			{ L _ LitChar			_ }+    LIT_FLOAT			{ L _ LitFloat			_ }     LIT_FALSE			{ L _ LitFalse			_ }     LIT_TRUE			{ L _ LitTrue			_ }     LIT_INTEGER			{ L _ LitInteger		_ }@@ -255,6 +257,7 @@ |	CMT_ATTR						{ $1 } |	CMT_REF							{ $1 } |	CMT_CODE						{ $1 }+|	LIT_FLOAT						{ $1 } |	LIT_INTEGER						{ $1 } |	LIT_STRING						{ $1 } |	' '							{ $1 }@@ -322,7 +325,8 @@  PreprocConstExpr :: { NonTerm } PreprocConstExpr-:	PureExpr(PreprocConstExpr)				{ $1 }+:	PreprocSafeExpr(PreprocConstExpr)			{ $1 }+|	PureExprOps(PreprocConstExpr)				{ $1 } |	'defined' '(' ID_CONST ')'				{ Fix $ PreprocDefined $3 }  MacroParamList :: { [NonTerm] }@@ -454,9 +458,9 @@  DeclSpecArray :: { NonTerm } DeclSpecArray-:	'[' ']'							{ Fix $ DeclSpecArray Nothing }-|	'[' Nullability Expr ']'				{ Fix $ DeclSpecArray (Just (Fix (ArrayDim $2 $3))) }-|	'[' '/*!' Expr '*/' ']'					{ Fix $ DeclSpecArray (Just $3) }+:	'[' Nullability ']'					{ Fix $ DeclSpecArray $2 Nothing }+|	'[' Nullability Expr ']'				{ Fix $ DeclSpecArray $2 (Just $3) }+|	'[' Nullability '/*!' Expr '*/' ']'			{ Fix $ DeclSpecArray $2 (Just $4) }  InitialiserExpr :: { NonTerm } InitialiserExpr@@ -484,19 +488,23 @@  -- Expressions that are safe for use as macro body without () around it.. PreprocSafeExpr(x)-:	LiteralExpr						{ $1 }-|	'(' x ')'						{ Fix $ ParenExpr $2 }+:	PreprocAtoms(x)						{ $1 } |	'(' QualType(LocalLeafType) ')' x %prec CAST		{ Fix $ CastExpr $2 $4 } |	sizeof '(' Expr ')'					{ Fix $ SizeofExpr $3 } |	sizeof '(' QualType(LocalLeafType) ')'			{ Fix $ SizeofType $3 } +PreprocAtoms(x)+:	LiteralExpr						{ $1 }+|	'(' x ')'						{ Fix $ ParenExpr $2 }+ ConstExpr :: { NonTerm } ConstExpr-:	PureExpr(ConstExpr)					{ $1 }+:	PreprocSafeExpr(ConstExpr)				{ $1 }+|	PureExprOps(ConstExpr)					{ $1 }+|	'defined' '(' ID_CONST ')'				{ Fix $ PreprocDefined $3 } -PureExpr(x)-:	PreprocSafeExpr(x)					{ $1 }-|	x '!=' x						{ Fix $ BinaryExpr $1 BopNe $3 }+PureExprOps(x)+:	x '!=' x						{ Fix $ BinaryExpr $1 BopNe $3 } |	x '==' x						{ Fix $ BinaryExpr $1 BopEq $3 } |	x '||' x						{ Fix $ BinaryExpr $1 BopOr $3 } |	x '^' x							{ Fix $ BinaryExpr $1 BopBitXor $3 }@@ -524,6 +532,7 @@ LiteralExpr :	StringLiteralExpr					{ $1 } |	LIT_CHAR						{ Fix $ LiteralExpr Char $1 }+|	LIT_FLOAT						{ Fix $ LiteralExpr Float $1 } |	LIT_INTEGER						{ Fix $ LiteralExpr Int $1 } |	LIT_FALSE						{ Fix $ LiteralExpr Bool $1 } |	LIT_TRUE						{ Fix $ LiteralExpr Bool $1 }@@ -534,21 +543,34 @@ :	LIT_STRING						{ Fix $ LiteralExpr String $1 } |	StringLiteralExpr LIT_STRING				{ $1 } +PrimaryExpr :: { NonTerm }+PrimaryExpr+:	ID_VAR							{ Fix $ VarExpr $1 }+|	LiteralExpr						{ $1 }+|	CompoundLiteral						{ $1 }+|	'(' Expr ')'						{ Fix $ ParenExpr $2 }++PostfixExpr :: { NonTerm }+PostfixExpr+:	PrimaryExpr						{ $1 }+|	PostfixExpr '[' Expr ']'				{ Fix $ ArrayAccess $1 $3 }+|	PostfixExpr '.' ID_VAR					{ Fix $ MemberAccess $1 $3 }+|	PostfixExpr '->' ID_VAR					{ Fix $ PointerAccess $1 $3 }+|	FunctionCall						{ $1 }+ LhsExpr :: { NonTerm } LhsExpr-:	ID_VAR							{ Fix $ VarExpr $1 }+:	PostfixExpr						{ $1 } |	'*' LhsExpr %prec DEREF					{ Fix $ UnaryExpr UopDeref $2 }-|	LhsExpr '.' ID_VAR					{ Fix $ MemberAccess $1 $3 }-|	LhsExpr '->' ID_VAR					{ Fix $ PointerAccess $1 $3 }-|	LhsExpr '[' Expr ']'					{ Fix $ ArrayAccess $1 $3 }  Expr :: { NonTerm } Expr :	LhsExpr							{ $1 }+|	PureExprOps(Expr)					{ $1 }+|	'(' QualType(LocalLeafType) ')' Expr %prec CAST		{ Fix $ CastExpr $2 $4 }+|	sizeof '(' Expr ')'					{ Fix $ SizeofExpr $3 }+|	sizeof '(' QualType(LocalLeafType) ')'			{ Fix $ SizeofType $3 } |	ExprStmt						{ $1 }-|	FunctionCall						{ $1 }-|	CompoundLiteral						{ $1 }-|	PureExpr(Expr)						{ $1 }  -- Allow `(Type){0}` to set struct values to all-zero. CompoundLiteral :: { NonTerm }@@ -559,6 +581,7 @@ ZeroInitExpr :	ID_VAR							{ Fix $ VarExpr $1 } |	LIT_CHAR						{ Fix $ LiteralExpr Char $1 }+|	LIT_FLOAT						{ Fix $ LiteralExpr Float $1 } |	LIT_INTEGER						{ Fix $ LiteralExpr Int $1 } |	LIT_FALSE						{ Fix $ LiteralExpr Bool $1 } |	ID_CONST						{ Fix $ LiteralExpr ConstId $1 }@@ -589,7 +612,7 @@  FunctionCall :: { NonTerm } FunctionCall-:	Expr ArgList						{ Fix $ FunctionCall $1 $2 }+:	PostfixExpr ArgList					{ Fix $ FunctionCall $1 $2 }  ArgList :: { [NonTerm] } ArgList@@ -669,7 +692,7 @@  QualType(leafType) :	bitwise ID_STD_TYPE					{ Fix (TyBitwise (Fix (TyStd $2))) }-|	force leafType						{ Fix (TyForce $2) }+|	force QualType(leafType)				{ Fix (TyForce $2) } |	leafType ConstQual					{                              ($2      $1)    } |	leafType ConstQual '*'					{                (tyPointer ($2      $1))   } |	leafType ConstQual '*' QualList				{                $4 (tyPointer ($2      $1))   }@@ -807,4 +830,7 @@ #else source = Nothing #endif++preprocessorEnabled :: Bool+preprocessorEnabled = False }

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict            #-}+module Language.Cimple.Parser.Error+    ( parseError+    ) where++import           Data.Aeson                 (encode)+import qualified Data.ByteString.Lazy.Char8 as LBSC+import           Data.Text                  (Text)+import           Language.Cimple.Lexer      (Alex, Lexeme (..), ParseError (..),+                                             alexError, getContext)+import           Language.Cimple.Tokens     (LexemeClass (..))++parseError :: (Lexeme Text, [String]) -> Alex a+parseError (l@(L p _ _), options) = do+    ctx <- getContext+    alexError $ LBSC.unpack (encode (ParseError p ctx options l))

@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict            #-}+module Language.Cimple.Parser.Error.Pretty+    ( describeContext+    , describeExpected+    , formatParseError+    ) where++import           Data.List                   (intercalate, isPrefixOf, nub,+                                              (\\))+import           Data.Maybe                  (fromMaybe, listToMaybe, mapMaybe)+import           Data.Text                   (Text)+import           Language.Cimple.DescribeAst (describeLexeme, describeNode,+                                              getLoc)+import           Language.Cimple.Lexer       (AlexPosn (..), Context (..),+                                              Lexeme (..), ParseError (..),+                                              lexemePosn)+import           Language.Cimple.Tokens      (LexemeClass (..))++formatParseError :: ParseError -> String+formatParseError (ParseError p@(AlexPn _ line col) ctx expected l) =+    let (AlexPn _ bestLine bestCol) = if line == 0 && col == 0+            then fromMaybe p $ listToMaybe $ mapMaybe getContextPosn ctx+            else p+        getContextPosn (ContextLexeme _ (L p' _ _)) = Just p'+        getContextPosn (ContextNode _ n)           = Just (lexemePosn (getLoc n))+        getContextPosn _                            = Nothing+        ctxNames = dedupe . filter (not . null) $ map describeContext ctx+        contextStr = if null ctxNames then "" else " while parsing " ++ intercalate " > " (reverse ctxNames)+        lexemeStr = " near " ++ describeLexeme l+        expectedStr = "; expected " ++ describeExpected expected+        hint = getHint ctx expected l+    in ":" ++ show bestLine ++ ":" ++ show bestCol ++ ": Parse error" ++ contextStr ++ lexemeStr ++ expectedStr ++ hint++dedupe :: Eq a => [a] -> [a]+dedupe []     = []+dedupe (x:xs) = x : dedupe (dropWhile (== x) xs)++getHint :: [Context] -> [String] -> Lexeme Text -> String+getHint ctx expected l+    | isTerminator l =+        let closers = nub $ filter isCloser expected ++ mapMaybe (closerForCtx . getContextName) ctx+        in if null closers+           then cimpleHint+           else "\nHint: Reached a terminator before finding the expected closing " ++ intercalate " or " closers ++ "."+    | isKeyword l && any isIdentifierToken expected =+        "\nHint: " ++ describeLexeme l ++ " is a reserved keyword and cannot be used as an identifier."+    | isIdentifier l && any isIdentifierToken expected =+        let expectedDesc = describeExpected (filter isIdentifierToken expected)+            foundDesc = describeLexeme l+        in "\nHint: Found " ++ foundDesc ++ ", but here we expected a " ++ expectedDesc ++ "."+    | otherwise = cimpleHint+  where+    cimpleHint = if any ((== "Endif") . getContextName) ctx && any ("'/*'" `isPrefixOf`) expected+                 then "\nHint: In Cimple, every #endif must be followed by a comment indicating what it closes (e.g. '#endif /* FLAG */')."+                 else ""++getContextName :: Context -> String+getContextName (Context name)         = name+getContextName (ContextLexeme name _) = name+getContextName (ContextNode name _)   = name++isIdentifier :: Lexeme Text -> Bool+isIdentifier (L _ c _) = c `elem` [IdVar, IdSueType, IdConst, IdFuncType, IdStdType]++isIdentifierToken :: String -> Bool+isIdentifierToken s = s `elem` ["ID_VAR", "ID_SUE_TYPE", "ID_CONST", "ID_FUNC_TYPE", "ID_STD_TYPE"]++isKeyword :: Lexeme Text -> Bool+isKeyword (L _ c _) = c >= KwBitwise && c <= KwWhile++closerForCtx :: String -> Maybe String+closerForCtx name = case name of+    "FunctionCall"                    -> Just "')'"+    "ArgList"                         -> Just "')'"+    "CompoundStmt"                    -> Just "'}'"+    "AggregateDecl"                   -> Just "'}'"+    "MemberDecls"                     -> Just "'}'"+    "EnumDecl"                        -> Just "'}'"+    "PostfixExpr"                     -> Just "']'" -- Often array access+    "PrimaryExpr"                     -> Just "')'" -- Parenthesized expr+    "ParenthesizedExpr"               -> Just "')'"+    "FunctionPrototype(ID_VAR)"       -> Just "')'"+    "FunctionPrototype(ID_FUNC_TYPE)" -> Just "')'"+    _                                 -> Nothing++isTerminator :: Lexeme Text -> Bool+isTerminator (L _ c _) = c `elem` [PctSemicolon, Eof, PpNewline]++isCloser :: String -> Bool+isCloser s = s `elem` ["')'", "'}'", "']'", "'*/'", "'@}'"]++describeContext :: Context -> String+describeContext (Context name) = describeContextName name+describeContext (ContextLexeme name l) =+    let name' = describeContextName name+        lex' = describeLexeme l+    in if null name' then lex'+       else if isIdentifier l then name' ++ " " ++ lex'+       else name'+describeContext (ContextNode name n) =+    let name' = describeContextName name+        node' = describeNode n+    in if null name' then node' else name' ++ " " ++ node'++describeContextName :: String -> String+describeContextName name = case name of+    "TranslationUnit"                         -> ""+    "ToplevelDecl"                            -> "top-level declaration"+    "Endif"                                   -> "#endif"+    "FunctionDecl"                            -> "function"+    "FunctionDefn"                            -> "function"+    "FunctionDeclarator"                      -> "function"+    "CompoundStmt"                            -> "block"+    "Stmt"                                    -> "statement"+    "VarDeclStmt"                             -> "variable declaration"+    "VarDecl"                                 -> "variable declaration"+    "MemberDecls"                             -> "struct/union members"+    "MemberDecl"                              -> "struct/union member"+    "IfStmt(CompoundStmt)"                    -> "if statement"+    "IfStmt(ReturnStmt)"                      -> "if statement"+    "ForStmt"                                 -> "for loop"+    "WhileStmt"                               -> "while loop"+    "DoWhileStmt"                             -> "do-while loop"+    "SwitchStmt"                              -> "switch statement"+    "AggregateDecl"                           -> "struct/union definition"+    "AggregateType"                           -> "struct/union definition"+    "EnumDecl"                                -> "enum definition"+    "ConstExpr"                               -> "constant expression"+    "Expr"                                    -> "expression"+    "PrimaryExpr"                             -> "expression"+    "FunctionCall"                            -> "function call"+    "MacroBody"                               -> "macro body"+    "FunctionPrototype(ID_VAR)"               -> "function"+    "FunctionPrototype(ID_FUNC_TYPE)"         -> "function"+    "PreprocIf(Stmts)"                        -> "#if block"+    "PreprocIfdef(Stmts)"                     -> "#ifdef block"+    "PreprocIf(ToplevelDecls)"                -> "#if block"+    "PreprocIfdef(ToplevelDecls)"             -> "#ifdef block"+    "Enumerator"                              -> "enumerator"+    "EnumeratorName"                          -> "enumerator"+    "InitialiserList"                         -> "initializer list"+    "QualType(LocalLeafType)"                 -> "type"+    "QualType(GlobalLeafType)"                -> "type"+    "LocalLeafType"                           -> "type"+    "GlobalLeafType"                          -> "type"+    _ | "FunctionPrototype" `isPrefixOf` name -> "function"+    _ | "PreprocIfdef" `isPrefixOf` name      -> "#ifdef block"+    _ | "PreprocIf" `isPrefixOf` name         -> "#if block"+    _ | "IfStmt" `isPrefixOf` name            -> "if statement"+    _ | "push_" `isPrefixOf` name             -> ""+    _                                         -> name++describeExpected :: [String] -> String+describeExpected [] = "end of file"+describeExpected [option] = describeTokenName option+describeExpected options+    | allComment options = "a comment"+    | wants ["break", "const", "continue", "ID_CONST", "VLA"] = "statement or declaration"+    | wants ["ID_FUNC_TYPE", "non_null", "static", "'#include'"] = "top-level declaration or definition"+    | options == ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "struct", "union", "void"] = "top-level type specifier"+    | options == ["ID_STD_TYPE", "ID_SUE_TYPE", "struct", "union", "void"] = "type specifier"+    | options == ["ID_STD_TYPE", "ID_SUE_TYPE", "bitwise", "const", "force", "struct", "union", "void"] = "type specifier"+    | options == ["ID_CONST", "ID_VAR", "LIT_CHAR", "LIT_FLOAT", "LIT_FALSE", "LIT_INTEGER", "'{'"] = "constant or literal"+    | ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "ID_VAR"] `isPrefixOf` options = "type specifier or variable name"+    | ["ID_FUNC_TYPE", "ID_STD_TYPE", "ID_SUE_TYPE", "bitwise", "const"] `isPrefixOf` options = "type specifier"+    | ["ID_CONST", "sizeof", "LIT_CHAR", "LIT_FALSE", "LIT_INTEGER"] `isPrefixOf` options = "constant expression"+    | ["ID_CONST", "ID_SUE_TYPE", "'/*'" ] `isPrefixOf` options = "enumerator, type name, or comment"+    | wants ["'defined'"] = "preprocessor constant expression"+    | wants ["'&'", "'&&'", "'*'", "'=='", "';'"] = "operator or end of statement"+    | wants ["'&'", "'&&'", "'*'", "'^'", "'!='"] = "operator"+    | wants ["ID_CONST", "ID_VAR", "LIT_CHAR", "'*'", "'('"] = "expression"+    | ["ID_CONST", "ID_STD_TYPE", "ID_SUE_TYPE", "ID_VAR", "const", "sizeof"] `isPrefixOf` options = "expression or type specifier"+    | ["ID_CONST", "ID_STD_TYPE", "ID_SUE_TYPE", "const", "sizeof"] `isPrefixOf` options = "constant expression or type specifier"+    | ["'&='", "'->'", "'*='"] `isPrefixOf` options = "assignment or member/array access"+    | wants ["'='", "'*='", "'/='", "'+='", "'-='"] = "assignment operator"+    | wants ["CMT_WORD"] = "comment contents"++    | length options == 2 = commaOr options+    | otherwise           = "one of " <> commaOr options+  where+    allComment opts = not (null opts) && all (`elem` ["'/*'", "'/**'", "'/***'", "'/** @{'", "'/** @} */'", "IGN_START"]) opts+    wants xs = null (xs \\ options)++describeTokenName :: String -> String+describeTokenName name = case name of+    "ID_VAR"       -> "variable name"+    "ID_SUE_TYPE"  -> "type name"+    "ID_CONST"     -> "constant name"+    "ID_FUNC_TYPE" -> "function type name"+    "ID_STD_TYPE"  -> "standard type name"+    _              -> name++commaOr :: [String] -> String+commaOr = go . reverse+  where+    go []     = ""+    go (x:xs) = intercalate ", " (reverse xs) <> " or " <> x

@@ -5,6 +5,8 @@     , render     , renderSmart     , ppTranslationUnit+    , ppNode+    , ppNodeF     , showNode     , showNodePlain     ) where@@ -199,10 +201,10 @@     . plain  ppNode :: Pretty a => Node (Lexeme a) -> Doc AnsiStyle-ppNode = foldFix go-  where-  go :: Pretty a => NodeF (Lexeme a) (Doc AnsiStyle) -> Doc AnsiStyle-  go = \case+ppNode = foldFix ppNodeF++ppNodeF :: Pretty a => NodeF (Lexeme a) (Doc AnsiStyle) -> Doc AnsiStyle+ppNodeF = \case     StaticAssert cond msg ->         kwStaticAssert <> parens (cond <> comma <+> dullred (ppLexeme msg)) <> semi @@ -237,7 +239,6 @@     FunctionCall c  a    -> ppFunctionCall c a     ArrayAccess  e  i    -> e <> pretty '[' <> i <> pretty ']'     CastExpr     ty e    -> parens ty <> e-    CompoundExpr    ty e -> parens ty <+> lbrace <> e <> rbrace  -- DEPRECATED     CompoundLiteral ty e -> parens ty <+> lbrace <> e <> rbrace     PreprocDefined  n    -> pretty "defined(" <> ppLexeme n <> pretty ')'     InitialiserList l    -> ppInitialiserList l@@ -247,9 +248,9 @@     Ellipsis             -> pretty "..."      VarDecl ty name arrs      -> ty <+> ppLexeme name <> hcat arrs-    DeclSpecArray Nothing     -> pretty "[]"-    DeclSpecArray (Just dim)  -> brackets dim-    ArrayDim nullability size -> ppNullability nullability <+> size+    DeclSpecArray nullability Nothing -> brackets (ppNullability nullability)+    DeclSpecArray NullabilityUnspecified (Just dim) -> brackets dim+    DeclSpecArray nullability (Just dim) -> brackets (ppNullability nullability <+> dim)      TyBitwise     ty -> kwBitwise <+> ty     TyForce       ty -> kwForce <+> ty

@@ -4,9 +4,11 @@     ( LexemeClass (..)     ) where -import           Data.Aeson    (FromJSON, ToJSON)-import           Data.Hashable (Hashable)-import           GHC.Generics  (Generic)+import           Data.Aeson      (FromJSON, ToJSON)+import           Data.Hashable   (Hashable)+import           GHC.Generics    (Generic)+import           Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum,+                                  suchThat)  data LexemeClass     = IdConst@@ -46,6 +48,7 @@     | LitFalse     | LitTrue     | LitChar+    | LitFloat     | LitInteger     | LitString     | LitSysInclude@@ -128,8 +131,15 @@      | ErrorToken     | Eof-    deriving (Enum, Bounded, Ord, Eq, Show, Generic)+    deriving (Enum, Bounded, Ord, Eq, Show, Read, Generic)  instance FromJSON LexemeClass instance ToJSON LexemeClass instance Hashable LexemeClass++instance Arbitrary LexemeClass where+    arbitrary = arbitraryBoundedEnum `suchThat` ok+      where+        ok ErrorToken = False+        ok Eof        = False+        ok _          = True

@@ -304,9 +304,7 @@             _ <- recurse name             _ <- recurse arrs             pure ()-        DeclSpecArray size ->-            recurse size-        ArrayDim _ size ->+        DeclSpecArray _nullability size ->             recurse size         InitialiserList values ->             recurse values@@ -328,10 +326,6 @@         ParenExpr expr ->             recurse expr         CastExpr ty expr -> do-            _ <- recurse ty-            _ <- recurse expr-            pure ()-        CompoundExpr ty expr -> do -- DEPRECATED             _ <- recurse ty             _ <- recurse expr             pure ()

@@ -4,15 +4,19 @@ {-# LANGUAGE ViewPatterns      #-} module Language.Cimple.AstSpec where +import           Data.Bifunctor       (Bifunctor (..)) import           Data.Fix             (Fix (..)) import           Data.Functor.Compose (Compose (..)) import           Test.Hspec           (Spec, describe, it, shouldBe,                                        shouldSatisfy) -import           Language.Cimple      (AlexPosn (..), AnnotF (..), Lexeme (..),-                                       LexemeClass (..), LiteralType (..),-                                       NodeF (..), Scope (..), addAnnot,-                                       removeAnnot)+import           Language.Cimple      (AlexPosn (..), AnnotF (..),+                                       AssignOp (..), BinaryOp (..),+                                       CommentF (..), CommentStyle (..),+                                       Lexeme (..), LexemeClass (..),+                                       LiteralType (..), NodeF (..),+                                       Nullability (..), Scope (..),+                                       UnaryOp (..), addAnnot, removeAnnot) import           Language.Cimple.IO   (parseText)  @@ -38,3 +42,147 @@                     (L (AlexPn 10 1 11) IdVar "a")                     (Fix (LiteralExpr Int (L (AlexPn 14 1 15) LitInteger "3"))))) -> True                 _ -> False++    describe "Bifunctor NodeF" $ do+        it "bimap maps lexemes and children" $ do+            let fl l = "l-" ++ l+            let fa a = "a-" ++ a+            let test n e = bimap fl fa n `shouldBe` e++            -- Preprocessor+            test (PreprocInclude "inc") (PreprocInclude "l-inc")+            test (PreprocDefine "def") (PreprocDefine "l-def")+            test (PreprocDefineConst "def" "const") (PreprocDefineConst "l-def" "a-const")+            test (PreprocDefineMacro "def" ["p1", "p2"] "body") (PreprocDefineMacro "l-def" ["a-p1", "a-p2"] "a-body")+            test (PreprocIf "cond" ["as"] "else") (PreprocIf "a-cond" ["a-as"] "a-else")+            test (PreprocIfdef "def" ["as"] "else") (PreprocIfdef "l-def" ["a-as"] "a-else")+            test (PreprocIfndef "def" ["as"] "else") (PreprocIfndef "l-def" ["a-as"] "a-else")+            test (PreprocElse ["as"]) (PreprocElse ["a-as"])+            test (PreprocElif "cond" ["as"] "else") (PreprocElif "a-cond" ["a-as"] "a-else")+            test (PreprocUndef "def") (PreprocUndef "l-def")+            test (PreprocDefined "def") (PreprocDefined "l-def")+            test (PreprocScopedDefine "a" ["as"] "a'") (PreprocScopedDefine "a-a" ["a-as"] "a-a'")+            test (MacroBodyStmt "a") (MacroBodyStmt "a-a")+            test (MacroBodyFunCall "a") (MacroBodyFunCall "a-a")+            test (MacroParam "l") (MacroParam "l-l")+            test (StaticAssert "a" "l") (StaticAssert "a-a" "l-l")++            -- Comments+            test (LicenseDecl "l" ["as"]) (LicenseDecl "l-l" ["a-as"])+            test (CopyrightDecl "l" (Just "ml") ["ls"]) (CopyrightDecl "l-l" (Just "l-ml") ["l-ls"])+            test (Comment Regular "l" ["ls"] "l'") (Comment Regular "l-l" ["l-ls"] "l-l'")+            test (CommentSection "a" ["as"] "a'") (CommentSection "a-a" ["a-as"] "a-a'")+            test (CommentSectionEnd "l") (CommentSectionEnd "l-l")+            test (Commented "a" "a'") (Commented "a-a" "a-a'")+            test (CommentInfo (Fix (DocWord "l"))) (CommentInfo (Fix (DocWord "l-l")))++            -- Namespace-like blocks+            test (ExternC ["as"]) (ExternC ["a-as"])+            test (Group ["as"]) (Group ["a-as"])++            -- Statements+            test (CompoundStmt ["as"]) (CompoundStmt ["a-as"])+            test Break Break+            test (Goto "l") (Goto "l-l")+            test Continue Continue+            test (Return (Just "ma")) (Return (Just "a-ma"))+            test (SwitchStmt "a" ["as"]) (SwitchStmt "a-a" ["a-as"])+            test (IfStmt "a" "a'" (Just "ma''")) (IfStmt "a-a" "a-a'" (Just "a-ma''"))+            test (ForStmt "a" "a'" "a''" "a'''") (ForStmt "a-a" "a-a'" "a-a''" "a-a'''")+            test (WhileStmt "a" "as") (WhileStmt "a-a" "a-as")+            test (DoWhileStmt "a" "a'") (DoWhileStmt "a-a" "a-a'")+            test (Case "a" "a'") (Case "a-a" "a-a'")+            test (Default "a") (Default "a-a")+            test (Label "l" "a") (Label "l-l" "a-a")+            test (ExprStmt "a") (ExprStmt "a-a")++            -- Variable declarations+            test (VLA "a" "l" "a'") (VLA "a-a" "l-l" "a-a'")+            test (VarDeclStmt "a" (Just "ma")) (VarDeclStmt "a-a" (Just "a-ma"))+            test (VarDecl "a" "l" ["as"]) (VarDecl "a-a" "l-l" ["a-as"])+            test (DeclSpecArray NullabilityUnspecified (Just "ma")) (DeclSpecArray NullabilityUnspecified (Just "a-ma"))++            -- Expressions+            test (InitialiserList ["as"]) (InitialiserList ["a-as"])+            test (UnaryExpr UopNot "a") (UnaryExpr UopNot "a-a")+            test (BinaryExpr "a" BopEq "a'") (BinaryExpr "a-a" BopEq "a-a'")+            test (TernaryExpr "a" "a'" "a''") (TernaryExpr "a-a" "a-a'" "a-a''")+            test (AssignExpr "a" AopEq "a'") (AssignExpr "a-a" AopEq "a-a'")+            test (ParenExpr "a") (ParenExpr "a-a")+            test (CastExpr "a" "a'") (CastExpr "a-a" "a-a'")+            test (CompoundLiteral "a" "a'") (CompoundLiteral "a-a" "a-a'")+            test (SizeofExpr "a") (SizeofExpr "a-a")+            test (SizeofType "a") (SizeofType "a-a")+            test (LiteralExpr Int "l") (LiteralExpr Int "l-l")+            test (VarExpr "l") (VarExpr "l-l")+            test (MemberAccess "a" "l") (MemberAccess "a-a" "l-l")+            test (PointerAccess "a" "l") (PointerAccess "a-a" "l-l")+            test (ArrayAccess "a" "a'") (ArrayAccess "a-a" "a-a'")+            test (FunctionCall "a" ["as"]) (FunctionCall "a-a" ["a-as"])+            test (CommentExpr "a" "a'") (CommentExpr "a-a" "a-a'")++            -- Type definitions+            test (EnumConsts (Just "ml") ["as"]) (EnumConsts (Just "l-ml") ["a-as"])+            test (EnumDecl "l" ["as"] "l'") (EnumDecl "l-l" ["a-as"] "l-l'")+            test (Enumerator "l" (Just "ma")) (Enumerator "l-l" (Just "a-ma"))+            test (AggregateDecl "a") (AggregateDecl "a-a")+            test (Typedef "a" "l") (Typedef "a-a" "l-l")+            test (TypedefFunction "a") (TypedefFunction "a-a")+            test (Struct "l" ["as"]) (Struct "l-l" ["a-as"])+            test (Union "l" ["as"]) (Union "l-l" ["a-as"])+            test (MemberDecl "a" (Just "ml")) (MemberDecl "a-a" (Just "l-ml"))+            test (TyBitwise "a") (TyBitwise "a-a")+            test (TyForce "a") (TyForce "a-a")+            test (TyConst "a") (TyConst "a-a")+            test (TyOwner "a") (TyOwner "a-a")+            test (TyNonnull "a") (TyNonnull "a-a")+            test (TyNullable "a") (TyNullable "a-a")+            test (TyPointer "a") (TyPointer "a-a")+            test (TyStruct "l") (TyStruct "l-l")+            test (TyUnion "l") (TyUnion "l-l")+            test (TyFunc "l") (TyFunc "l-l")+            test (TyStd "l") (TyStd "l-l")+            test (TyUserDefined "l") (TyUserDefined "l-l")++            -- Functions+            test (AttrPrintf "l" "l'" "a") (AttrPrintf "l-l" "l-l'" "a-a")+            test (FunctionDecl Global "a") (FunctionDecl Global "a-a")+            test (FunctionDefn Global "a" "a'") (FunctionDefn Global "a-a" "a-a'")+            test (FunctionPrototype "a" "l" ["as"]) (FunctionPrototype "a-a" "l-l" ["a-as"])+            test (CallbackDecl "l" "l'") (CallbackDecl "l-l" "l-l'")+            test Ellipsis Ellipsis+            test (NonNull ["ls"] ["ls'"] "a") (NonNull ["l-ls"] ["l-ls'"] "a-a")+            test (NonNullParam "a") (NonNullParam "a-a")+            test (NullableParam "a") (NullableParam "a-a")++            -- Constants+            test (ConstDecl "a" "l") (ConstDecl "a-a" "l-l")+            test (ConstDefn Global "a" "l" "a'") (ConstDefn Global "a-a" "l-l" "a-a'")++    describe "Bifunctor CommentF" $ do+        it "bimap maps lexemes and children" $ do+            let fl l = "l-" ++ l+            let fa a = "a-" ++ a+            let test n e = bimap fl fa n `shouldBe` e++            test (DocComment ["as"]) (DocComment ["a-as"])+            test DocAttention DocAttention+            test DocBrief DocBrief+            test DocDeprecated DocDeprecated+            test (DocExtends "l") (DocExtends "l-l")+            test DocFile DocFile+            test (DocImplements "l") (DocImplements "l-l")+            test DocNote DocNote+            test (DocParam (Just "ml") "l") (DocParam (Just "l-ml") "l-l")+            test DocReturn DocReturn+            test DocRetval DocRetval+            test (DocSection "l") (DocSection "l-l")+            test (DocSecurityRank "l" (Just "ml") "l'") (DocSecurityRank "l-l" (Just "l-ml") "l-l'")+            test (DocSee "l") (DocSee "l-l")+            test (DocSubsection "l") (DocSubsection "l-l")+            test DocPrivate DocPrivate+            test (DocLine ["as"]) (DocLine ["a-as"])+            test (DocCode "l" ["as"] "l'") (DocCode "l-l" ["a-as"] "l-l'")+            test (DocWord "l") (DocWord "l-l")+            test (DocRef "l") (DocRef "l-l")+            test (DocP "l") (DocP "l-l")

@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-orphans #-}-module Language.Cimple.DescribeAstSpec where--import           Test.Hspec          (Spec, describe, it, shouldBe,-                                      shouldNotContain)--import           Control.Monad       (unless)-import           Data.List           (isInfixOf)-import qualified Data.List.Extra     as List-import           Data.Text           (Text)-import qualified Data.Text           as Text-import           Language.Cimple.IO  (parseExpr, parseStmt, parseText)-import           Language.CimpleSpec (sampleToken)-import           Test.QuickCheck     (Testable (property))---expected :: (Text -> Either String a) -> Text -> String-expected parse code =-    case parse code of-        Left err -> snd $ List.breakOn "expected " err-        Right _  -> ""---spec :: Spec-spec = do-    describe "error messages" $ do-        it "has useful suggestions" $ do-            parseText "int a() {}" `shouldBe` Left-                ":1:10: Parse error near right brace: \"}\"; expected statement or declaration"--            expected parseText "Beep Boop" `shouldBe`-                "expected variable name"--            expected parseText "const *a() {}" `shouldBe`-                "expected type specifier"--            expected parseText "int a() { int }" `shouldBe`-                "expected variable name"--            expected parseStmt "(int){" `shouldBe`-                "expected constant or literal"--        it "has suggestions for any sequence of tokens in top level" $ do-            property $ \tokens -> do-                let msg = expected parseText (Text.intercalate " " (map sampleToken tokens))-                unless ("\"ifndefDefine\"" `isInfixOf` msg) $-                    msg `shouldNotContain` "expected one of"--        it "has suggestions for any sequence of tokens in expressions" $ do-            property $ \tokens ->-                expected parseExpr (Text.intercalate " " (map sampleToken tokens)) `shouldNotContain`-                    "expected one of"--        it "has suggestions for any sequence of tokens in statements" $ do-            property $ \tokens ->-                expected parseStmt (Text.intercalate " " (map sampleToken tokens)) `shouldNotContain`-                    "expected one of"--        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 comma: \",\"; expected '=' or ';'"

@@ -1,16 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Cimple.ParserSpec where -import           Data.Fix           (Fix (..))-import           Data.Text          (Text)-import qualified Data.Text          as Text-import           Test.Hspec         (Spec, describe, it, shouldBe,-                                     shouldSatisfy)--import           Language.Cimple    (AlexPosn (..), Lexeme (..),-                                     LexemeClass (..), Node, NodeF (..),-                                     Scope (..))-import           Language.Cimple.IO (parseText)+import           Control.Monad       (unless, when)+import           Data.Fix            (Fix (..))+import           Data.List           (isInfixOf)+import qualified Data.List.Extra     as List+import           Data.Text           (Text)+import qualified Data.Text           as Text+import           Language.Cimple     (AlexPosn (..), Lexeme (..),+                                      LexemeClass (..), Node, NodeF (..),+                                      Scope (..), UnaryOp (..),+                                      formatParseError, preprocessorEnabled)+import           Language.Cimple.IO  (parseExpr, parseStmt, parseText)+import           Language.CimpleSpec (sampleToken)+import           Test.Hspec          (Spec, describe, expectationFailure, it,+                                      pendingWith, shouldBe, shouldSatisfy)+import           Test.QuickCheck     (Testable (property))   isRight1 :: Either a [b] -> Bool@@ -29,6 +34,16 @@             let ast = parseText "int a(void) { return 3; }"             ast `shouldSatisfy` isRight1 +        it "should parse dereferencing a function pointer" $ do+            let ast = parseText "void f() { struct My_Struct s_var = *get_s(1); }"+            ast `shouldSatisfy` isRight1++        it "should parse *f(x) as *(f(x))" $ do+            let ast = parseLines ["void g() { int x = *f(1); }"]+            case ast of+                Right [Fix (FunctionDefn _ _ (Fix (CompoundStmt [Fix (VarDeclStmt _ (Just (Fix (UnaryExpr UopDeref (Fix (FunctionCall (Fix (VarExpr (L _ _ "f"))) [_]))))))])))] -> return ()+                _ -> expectationFailure $ "Unexpected AST: " ++ show ast+         it "should parse per-param non_null and nullable annotations" $ do             let ast = parseText "int a(char *_Nonnull p, int *_Nullable q);"             ast `shouldSatisfy` isRight1@@ -72,3 +87,133 @@                               (L (AlexPn 17 1 18) IdVar "a")                               [])) Nothing)])))                 ]++    if preprocessorEnabled+    then do+        describe "error messages" $ do+            let expected parse code =+                    case parse code of+                        Left err -> snd $ List.breakOn "expected " err+                        Right _  -> ""++            when preprocessorEnabled $ do+                it "includes context breadcrumbs" $ do+                    parseText "int a() { if (1) x = 1; }" `shouldBe` Left+                        ":1:18: Parse error while parsing function near variable name: \"x\"; expected return or '{'"++                it "has useful suggestions" $ do+                    parseText "int a() {}" `shouldBe` Left+                        ":1:10: Parse error while parsing function near right brace: \"}\"; expected statement or declaration"++            it "has useful suggestions (no context)" $ do+                expected parseText "Beep Boop" `shouldBe`+                    "expected variable name\nHint: Found type name: \"Boop\", but here we expected a variable name."++                expected parseText "const *a() {}" `shouldBe`+                    "expected type specifier"++                expected parseText "int a() { int }" `shouldBe`+                    "expected variable name"++                expected parseStmt "(int){" `shouldBe`+                    "expected constant or literal"++            it "has suggestions for any sequence of tokens in top level" $ do+                property $ \tokens -> do+                    let msg = expected parseText (Text.intercalate " " (map sampleToken tokens))+                    unless ("\"ifndefDefine\"" `isInfixOf` msg) $+                        msg `shouldSatisfy` (not . List.isInfixOf "expected one of")++            it "has suggestions for any sequence of tokens in expressions" $ do+                property $ \tokens ->+                    expected parseExpr (Text.intercalate " " (map sampleToken tokens)) `shouldSatisfy`+                        (not . List.isInfixOf "expected one of")++            it "has suggestions for any sequence of tokens in statements" $ do+                property $ \tokens ->+                    expected parseStmt (Text.intercalate " " (map sampleToken tokens)) `shouldSatisfy`+                        (not . List.isInfixOf "expected one of")++            it "does not support multiple declarators per declaration" $ do+                let ast = parseText "int main() { int a, b; }"+                ast `shouldBe` Left+                    ":1:19: Parse error while parsing function > variable declaration near comma: \",\"; expected '=' or ';'"++        describe "contextual error messages" $ do+            it "reports errors in struct definitions" $ do+                parseText "struct My_Struct { int a }" `shouldBe` Left+                    ":1:26: Parse error while parsing struct/union definition type name: \"My_Struct\" near right brace: \"}\"; expected ':' or ';'"++            it "reports errors in enum definitions" $ do+                parseText "enum My_Enum { A, B= }" `shouldBe` Left+                    ":1:22: Parse error while parsing enum definition type name: \"My_Enum\" near right brace: \"}\"; expected preprocessor constant expression"++            it "reports errors in for loop headers" $ do+                parseText "void f() { for (int i=0; i<10) {} }" `shouldBe` Left+                    ":1:30: Parse error while parsing function near right parenthesis: \")\"; expected operator or end of statement"++            it "reports errors in nested blocks" $ do+                parseText "void f() { { int x = 1 } }" `shouldBe` Left+                    ":1:24: Parse error while parsing function > variable declaration near right brace: \"}\"; expected ';'"++            it "reports missing comment after #endif" $ do+                parseText "#ifdef A\nvoid f() { return; }\n#endif" `shouldBe` Left+                    ":3:1: Parse error while parsing #endif near end-of-file: \"\"; expected a comment\nHint: In Cimple, every #endif must be followed by a comment indicating what it closes (e.g. '#endif /* FLAG */')."++            it "includes captured lexemes in breadcrumbs" $ do+                pendingWith "no function name tracking yet"+                parseText "void my_func() { int x = 1 }" `shouldBe` Left+                    ":1:28: Parse error while parsing function variable name: \"my_func\" > variable declaration near right brace: \"}\"; expected ';'"++            it "reports errors in nested blocks with full context" $ do+                pendingWith "no function name tracking yet"+                parseText "void f() { { int x = 1; if (1) { y } } }" `shouldBe` Left+                    ":1:35: Parse error while parsing function near variable name: \"y\"; expected return or '{'"++            it "uses context location for EOF errors in functions" $ do+                pendingWith "no function name tracking yet"+                parseText "void unclosed_func(int x) {" `shouldBe` Left+                    ":1:6: Parse error while parsing function variable name: \"unclosed_func\" near end-of-file: \"\"; expected statement or declaration\nHint: Reached a terminator before finding the expected closing '}'."++            it "reports errors in function calls" $ do+                parseText "void f() { g(a, ); }" `shouldBe` Left+                    ":1:17: Parse error while parsing function near right parenthesis: \")\"; expected expression"++            it "reports errors in preprocessor blocks" $ do+                parseText "#if 1\nvoid f() {;\n#else\nint b\n#endif" `shouldBe` Left+                    ":2:11: Parse error while parsing function near end of statement semicolon: \";\"; expected statement or declaration"++            it "reports errors in macro bodies" $ do+                -- This is a semantic check in Parser.y, not a standard parse error.+                parseText "#define M(x) do { x = 1; } while (1)" `shouldBe` Left+                    "L (AlexPn 34 1 35) LitInteger \"1\": macro do-while body must end in 'while (0)'"++        describe "generic hints" $ do+            it "detects unclosed parenthesis in function calls" $ do+                -- In a function call, a semicolon is a hard terminator.+                -- The parser expects more arguments (',') or the end of the list (')').+                parseText "void f() { g(1; }" `shouldBe` Left+                    ":1:15: Parse error while parsing function near end of statement semicolon: \";\"; expected ',' or ')'\nHint: Reached a terminator before finding the expected closing ')'."++            it "detects unclosed brackets in array access" $ do+                parseExpr "a[1;" `shouldBe` Left+                    ":1:4: Parse error near end of statement semicolon: \";\"; expected operator\nHint: Reached a terminator before finding the expected closing ']'."++            it "detects unclosed braces in struct definitions" $ do+                parseText "struct My_Struct { int a; " `shouldBe` Left+                    ":1:8: Parse error while parsing struct/union definition type name: \"My_Struct\" near end-of-file: \"\"; expected '}'\nHint: Reached a terminator before finding the expected closing '}'."++            it "reports identifier category mismatch" $ do+                parseText "struct S { int a; };" `shouldBe` Left+                    ":1:8: Parse error near constant name: \"S\"; expected type name\nHint: Found constant name: \"S\", but here we expected a type name."++            it "reports reserved keyword used as identifier" $ do+                parseText "int if = 1;" `shouldBe` Left+                    ":1:5: Parse error near \"if\"; expected variable name\nHint: \"if\" is a reserved keyword and cannot be used as an identifier."++    else do+        describe "error messages" $ do+            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 comma: \",\"; expected '=' or ';'"

@@ -0,0 +1,617 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Cimple.PrettyCommentSpec where++import           Test.Hspec                    (Spec, describe, it, shouldBe)++import           Data.Text                     (Text)+import qualified Data.Text                     as Text+import qualified Data.Text.Lazy                as TL+import           Language.Cimple               (Lexeme, Node)+import           Language.Cimple.IO            (parseText)+import           Language.Cimple.Pretty        (plain, ppTranslationUnit,+                                                renderSmart)+import           Prettyprinter                 (SimpleDocStream, layoutCompact)+import           Prettyprinter.Render.Terminal (AnsiStyle, renderLazy)++getRight :: Either String a -> a+getRight (Left  err) = error err+getRight (Right ok ) = ok++compact :: String -> String+compact =+    flip displayS ""+    . renderSmart 1 120+    . plain+    . ppTranslationUnit+    . mustParse++mustParse :: String -> [Node (Lexeme Text)]+mustParse =+    getRight+    . parseText+    . Text.pack++displayS :: SimpleDocStream AnsiStyle -> ShowS+displayS sdoc =+    let rendered = renderLazy sdoc+    in (TL.unpack rendered ++)++spec :: Spec+spec = do+    -- implementation: PrettyComment.hs (ppCommentInfo).+    describe "Doxygen comment pretty-printing" $ do+        it "should pretty-print a doc comment" $+            compact (unlines+                [ "/**"+                , " * @brief hello world."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @brief hello world."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a doc comment with a paragraph" $+            compact (unlines+                [ "/**"+                , " * @brief hello world."+                , " *"+                , " * There's more to say about today."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @brief hello world."+                , " *"+                , " * There's more to say about today."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a @param" $+            compact (unlines+                [ "/**"+                , " * @param p1 hello world."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @param p1 hello world."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a @param with [in] attribute" $+            compact (unlines+                [ "/**"+                , " * @param[in] p1 hello world."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @param[in] p1 hello world."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a @return" $+            compact (unlines+                [ "/**"+                , " * @return hello world."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @return hello world."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a @retval" $+            compact (unlines+                [ "/**"+                , " * @retval 0 Success."+                , " * @retval 1 Failure."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @retval 0 Success."+                , " * @retval 1 Failure."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a bullet list" $+            compact (unlines+                [ "/**"+                , " * - item 1"+                , " * - item 2"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * - item 1"+                , " * - item 2"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a nested bullet list" $+            compact (unlines+                [ "/**"+                , " * - item 1"+                , " *   - nested item 1"+                , " * - item 2"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * - item 1"+                , " *   - nested item 1"+                , " * - item 2"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a numbered list" $+            compact (unlines+                [ "/**"+                , " * 1. item 1"+                , " * 2. item 2"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * 1. item 1"+                , " * 2. item 2"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a code block" $+            compact (unlines+                [ "/**"+                , " * @code"+                , " * int x = 5,"+                , " *     y = 3;"+                , " * @endcode"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @code"+                , " * int x = 5,"+                , " *     y = 3;"+                , " * @endcode"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @deprecated" $+            compact (unlines+                [ "/**"+                , " * @deprecated Use new_function instead."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @deprecated Use new_function instead."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @see" $+            compact (unlines+                [ "/**"+                , " * @see other_function for more details."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @see other_function for more details."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @attention" $+            compact (unlines+                [ "/**"+                , " * @attention This is important."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @attention This is important."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @note" $+            compact (unlines+                [ "/**"+                , " * @note This is a note."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @note This is a note."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @private" $+            compact (unlines+                [ "/**"+                , " * @private"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @private"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @extends" $+            compact (unlines+                [ "/**"+                , " * @extends BaseClass"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @extends BaseClass"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @implements" $+            compact (unlines+                [ "/**"+                , " * @implements Interface"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @implements Interface"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @security_rank" $+            compact (unlines+                [ "/**"+                , " * @security_rank(sink, data, 1)"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @security_rank(sink, data, 1)"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print a complex comment" $+            compact (unlines+                [ "/**"+                , " * @brief A brief description."+                , " *"+                , " * A more detailed description."+                , " * - list item 1"+                , " * - list item 2"+                , " *"+                , " * @param p1 Description for p1."+                , " * @return Description for return."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @brief A brief description."+                , " *"+                , " * A more detailed description."+                , " * - list item 1"+                , " * - list item 2"+                , " *"+                , " * @param p1 Description for p1."+                , " * @return Description for return."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with operators" $+            compact (unlines+                [ "/**"+                , " * check if x == 5"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * check if x == 5"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @ref" $+            compact (unlines+                [ "/**"+                , " * see @ref my_ref"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * see @ref my_ref"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @p" $+            compact (unlines+                [ "/**"+                , " * @p my_p"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @p my_p"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @file" $+            compact (unlines+                [ "/**"+                , " * @file"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @file"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @section" $+            compact (unlines+                [ "/**"+                , " * @section sec_id sec_title"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @section sec_id sec_title"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print @subsection" $+            compact (unlines+                [ "/**"+                , " * @subsection subsec_id subsec_title"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * @subsection subsec_id subsec_title"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with colon" $+            compact (unlines+                [ "/**"+                , " * Note:"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * Note:"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with parens" $+            compact (unlines+                [ "/**"+                , " * (Note)"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * (Note)"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with parens including long sentences going to the next line" $+            compact (unlines+                [ "/**"+                , " * This is a comment (and there is more"+                , " * to say about this)."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * This is a comment (and there is more"+                , " * to say about this)."+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with operators" $+            compact (unlines+                [ "/**"+                , " * a + b = c"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * a + b = c"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print words with assignment" $+            compact (unlines+                [ "/**"+                , " * x = 5"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * x = 5"+                , " */"+                , "const int abc = 3;"+                ]++        it "should pretty-print sentences with various punctuation" $+            compact (unlines+                [ "/**"+                , " * Is this a question?"+                , " * This is exciting!"+                , " * This is a clause;"+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * Is this a question?"+                , " * This is exciting!"+                , " * This is a clause;"+                , " */"+                , "const int abc = 3;"+                ]++        it "should allow numbers in the text" $+            compact (unlines+                [ "/**"+                , " * I have 3 things on my mind."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * I have 3 things on my mind."+                , " */"+                , "const int abc = 3;"+                ]++        it "should allow numbers at the start of the text" $+            compact (unlines+                [ "/**"+                , " * I have 3 things on my mind. You have"+                , " * 20 things on your mind. We are not the same."+                , " */"+                , "const int my_mind = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * I have 3 things on my mind. You have"+                , " * 20 things on your mind. We are not the same."+                , " */"+                , "const int my_mind = 3;"+                ]++        it "should allow numbers at the end of the sentence at the start of a line" $+            compact (unlines+                [ "/**"+                , " * I have 3 things on my mind. The number of things on your mind is"+                , " * 20."+                , " */"+                , "const int my_mind = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * I have 3 things on my mind. The number of things on your mind is"+                , " * 20."+                , " */"+                , "const int my_mind = 3;"+                ]++        it "should treat numbers like words and be able to continue normally" $+            compact (unlines+                [ "/**"+                , " * Here is a bunch of text and then on the next line there is"+                , " * 1, maybe more or less, and we can talk a lot about"+                , " * 2022. This is the next sentence."+                , " */"+                , "const int my_mind = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * Here is a bunch of text and then on the next line there is"+                , " * 1, maybe more or less, and we can talk a lot about"+                , " * 2022. This is the next sentence."+                , " */"+                , "const int my_mind = 3;"+                ]++        it "should print numbered lists as is" $+            compact (unlines+                [ "/**"+                , " * Here is a bunch of text and now follows a list."+                , " *"+                , " * 1. This is the first item."+                , " * 2. This is the second item."+                , " *"+                , " * Here is some more text not part of the list items."+                , " */"+                , "const int my_mind = 3;"+                ])+            `shouldBe` unlines+                [ "/**"+                , " * Here is a bunch of text and now follows a list."+                , " *"+                , " * 1. This is the first item."+                , " * 2. This is the second item."+                , " *"+                , " * Here is some more text not part of the list items."+                , " */"+                , "const int my_mind = 3;"+                ]++        it "should pretty-print a doc comment with content on the first line" $+            compact (unlines+                [ "/** @file test.c"+                , " * @brief hello world."+                , " */"+                , "const int abc = 3;"+                ])+            `shouldBe` unlines+                [ "/** @file test.c"+                , " * @brief hello world."+                , " */"+                , "const int abc = 3;"+                ]

@@ -69,7 +69,9 @@      describe "showNode" $ do         it "prints code with syntax highlighting" $ do-            let pp = showNode $ head $ mustParse "int a(void) { return 3; }"+            let pp = case mustParse "int a(void) { return 3; }" of+                    (x:_) -> showNode x+                    []    -> error "mustParse returned empty list"             pp <> "\n" `shouldBe` Text.unlines                 [ "\ESC[0;32mint\ESC[0m a(\ESC[0;32mvoid\ESC[0m) {"                 , "  \ESC[0;31mreturn\ESC[0m \ESC[0;31m3\ESC[0m;"@@ -170,6 +172,10 @@                 `shouldBe` "void foo(int a, ...);\n"             compact "void foo(int a, const char *msg, ...);"                 `shouldBe` "void foo(int a, char const* msg, ...);\n"++        it "formats array parameters" $ do+            compact "void f(int matrix[ 10][ 10], int j);"+                `shouldBe` "void f(int matrix[10][10], int j);\n"          it "supports C preprocessor directives" $ do             compact "#ifndef XYZZY\n#define XYZZY 123\n#endif /* XYZZY */\n"

@@ -6,15 +6,7 @@  import           Data.Text       (Text) import           Language.Cimple (LexemeClass (..))-import           Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum, forAll,-                                  suchThat)--instance Arbitrary LexemeClass where-    arbitrary = arbitraryBoundedEnum `suchThat` ok-      where-        ok ErrorToken = False-        ok Eof        = False-        ok _          = True+import           Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum, forAll)   sampleToken :: LexemeClass -> Text@@ -56,6 +48,7 @@     LitFalse              -> "false"     LitTrue               -> "true"     LitChar               -> "'a'"+    LitFloat              -> "1.23"     LitInteger            -> "123"     LitString             -> "\"str\""     LitSysInclude         -> "<stdio.h>"

@@ -1,15 +1,35 @@ module Main (main) where  import qualified Data.ByteString        as BS-import           Data.List              (isPrefixOf)+import qualified Data.ByteString.Lazy   as LBS import           Data.Text              (Text) import qualified Data.Text.Encoding     as Text import           Language.Cimple        (Lexeme, Node)-import           Language.Cimple.IO     (parseFile, parseText)+import           Language.Cimple.IO     (parseText, parseUnit) import           Language.Cimple.Pretty (plain, ppTranslationUnit, render)-import           System.Environment     (getArgs)+import           Options.Applicative    (Parser, argument, execParser, fullDesc,+                                         header, help, helper, info, long, many,+                                         metavar, progDesc, str, switch)  +data Options = Options+    { reparse      :: Bool+    , noTreeParser :: Bool+    , files        :: [FilePath]+    }+++options :: Parser Options+options = Options+    <$> switch+        ( long "reparse"+       <> help "Reparse the output to ensure validity" )+    <*> switch+        ( long "no-tree-parser"+       <> help "Do not use the tree parser (faster, less strict)" )+    <*> many (argument str (metavar "FILES..."))++ format :: Bool -> [Node (Lexeme Text)] -> Text format color = render . maybePlain . ppTranslationUnit   where@@ -26,19 +46,28 @@         Right _ -> return ()  -processFile :: [String] -> FilePath -> IO ()-processFile flags source = do-    putStrLn $ "Processing " ++ source-    ast <- parseFile source+processInput :: Options -> FilePath -> LBS.ByteString -> IO ()+processInput opts source input = do+    let ast = parseUnit (not $ noTreeParser opts) input     case ast of-        Left err -> putStrLn err >> fail "aborting after parse error"-        Right (_, ok) ->-            if "--reparse" `elem` flags+        Left err -> putStrLn (source <> err) >> fail "aborting after parse error"+        Right ok ->+            if reparse opts                then reparseText $ format False ok                else BS.putStr . Text.encodeUtf8 . format True $ ok   main :: IO () main = do-    (flags, files) <- span ("-" `isPrefixOf`) <$> getArgs-    mapM_ (processFile flags) files+    opts <- execParser optsInfo+    let sources = files opts+    if null sources+        then do+            content <- LBS.fromStrict <$> BS.getContents+            processInput opts "<stdin>" content+        else mapM_ (\f -> LBS.readFile f >>= processInput opts f) sources+  where+    optsInfo = info (helper <*> options)+        ( fullDesc+       <> progDesc "Format Cimple source files"+       <> header "cimplefmt - a formatter for Cimple" )