diff --git a/cimple.cabal b/cimple.cabal --- a/cimple.cabal +++ b/cimple.cabal @@ -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 diff --git a/src/Language/Cimple.hs b/src/Language/Cimple.hs --- a/src/Language/Cimple.hs +++ b/src/Language/Cimple.hs @@ -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 diff --git a/src/Language/Cimple/Ast.hs b/src/Language/Cimple/Ast.hs --- a/src/Language/Cimple/Ast.hs +++ b/src/Language/Cimple/Ast.hs @@ -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 diff --git a/src/Language/Cimple/DescribeAst.hs b/src/Language/Cimple/DescribeAst.hs --- a/src/Language/Cimple/DescribeAst.hs +++ b/src/Language/Cimple/DescribeAst.hs @@ -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 diff --git a/src/Language/Cimple/Flatten.hs b/src/Language/Cimple/Flatten.hs --- a/src/Language/Cimple/Flatten.hs +++ b/src/Language/Cimple/Flatten.hs @@ -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 diff --git a/src/Language/Cimple/IO.hs b/src/Language/Cimple/IO.hs --- a/src/Language/Cimple/IO.hs +++ b/src/Language/Cimple/IO.hs @@ -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)) diff --git a/src/Language/Cimple/Lexer.x b/src/Language/Cimple/Lexer.x --- a/src/Language/Cimple/Lexer.x +++ b/src/Language/Cimple/Lexer.x @@ -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 = diff --git a/src/Language/Cimple/MapAst.hs b/src/Language/Cimple/MapAst.hs --- a/src/Language/Cimple/MapAst.hs +++ b/src/Language/Cimple/MapAst.hs @@ -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 -> diff --git a/src/Language/Cimple/Parser.y b/src/Language/Cimple/Parser.y --- a/src/Language/Cimple/Parser.y +++ b/src/Language/Cimple/Parser.y @@ -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 } diff --git a/src/Language/Cimple/Parser/Error.hs b/src/Language/Cimple/Parser/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/Parser/Error.hs @@ -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)) diff --git a/src/Language/Cimple/Parser/Error/Pretty.hs b/src/Language/Cimple/Parser/Error/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/Parser/Error/Pretty.hs @@ -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 diff --git a/src/Language/Cimple/Pretty.hs b/src/Language/Cimple/Pretty.hs --- a/src/Language/Cimple/Pretty.hs +++ b/src/Language/Cimple/Pretty.hs @@ -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 diff --git a/src/Language/Cimple/Tokens.hs b/src/Language/Cimple/Tokens.hs --- a/src/Language/Cimple/Tokens.hs +++ b/src/Language/Cimple/Tokens.hs @@ -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 diff --git a/src/Language/Cimple/TraverseAst.hs b/src/Language/Cimple/TraverseAst.hs --- a/src/Language/Cimple/TraverseAst.hs +++ b/src/Language/Cimple/TraverseAst.hs @@ -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 () diff --git a/test/Language/Cimple/AstSpec.hs b/test/Language/Cimple/AstSpec.hs --- a/test/Language/Cimple/AstSpec.hs +++ b/test/Language/Cimple/AstSpec.hs @@ -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") diff --git a/test/Language/Cimple/DescribeAstSpec.hs b/test/Language/Cimple/DescribeAstSpec.hs deleted file mode 100644 --- a/test/Language/Cimple/DescribeAstSpec.hs +++ /dev/null @@ -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 ';'" diff --git a/test/Language/Cimple/ParserSpec.hs b/test/Language/Cimple/ParserSpec.hs --- a/test/Language/Cimple/ParserSpec.hs +++ b/test/Language/Cimple/ParserSpec.hs @@ -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 ';'" diff --git a/test/Language/Cimple/PrettyCommentSpec.hs b/test/Language/Cimple/PrettyCommentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Cimple/PrettyCommentSpec.hs @@ -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;" + ] diff --git a/test/Language/Cimple/PrettySpec.hs b/test/Language/Cimple/PrettySpec.hs --- a/test/Language/Cimple/PrettySpec.hs +++ b/test/Language/Cimple/PrettySpec.hs @@ -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" diff --git a/test/Language/CimpleSpec.hs b/test/Language/CimpleSpec.hs --- a/test/Language/CimpleSpec.hs +++ b/test/Language/CimpleSpec.hs @@ -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 -> "" diff --git a/tools/cimplefmt.hs b/tools/cimplefmt.hs --- a/tools/cimplefmt.hs +++ b/tools/cimplefmt.hs @@ -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 "" 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" )