Skip to content

Commit

Permalink
test: Add a test using happy-arbitrary.
Browse files Browse the repository at this point in the history 
This produces valid C code that should then be parseable again by the
Cimple parser.
  • Loading branch information
@iphydf
iphydf committed Jan 18, 2024
1 parent 85736b9 commit 9ca3810
Show file tree
Hide file tree
Showing 6 changed files with 192 additions and 20 deletions.
3 changes: 3 additions & 0 deletions BUILD.bazel
View file
Original file line number Diff line number Diff line change
Expand Up @@ -201,8 +201,11 @@ hspec_test(
size = "small",
deps = [
":hs-cimple",
"//hs-happy-arbitrary",
"//third_party/haskell:QuickCheck",
"//third_party/haskell:ansi-wl-pprint",
"//third_party/haskell:base",
"//third_party/haskell:bytestring",
"//third_party/haskell:data-fix",
"//third_party/haskell:hspec",
"//third_party/haskell:text",
Expand Down
3 changes: 3 additions & 0 deletions cimple.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -119,9 +119,12 @@ test-suite testsuite
build-tool-depends: hspec-discover:hspec-discover
build-depends:
ansi-wl-pprint
, QuickCheck
, base <5
, bytestring
, cimple
, data-fix
, happy-arbitrary
, hspec
, text
, transformers-compat
1 change: 1 addition & 0 deletions expand_yacc.pl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,7 @@ sub show_nonterm {
my ($res, $name, $nonterm) = @_;

push @$res, "$name :: { $nonterm->{type} }";
push @$res, "$name";
my @prod_res;
for my $prod (@{ $nonterm->{productions} }) {
show_production \@prod_res, $prod;
Expand Down
26 changes: 13 additions & 13 deletions src/Language/Cimple/Parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -315,8 +315,8 @@ PreprocUndef

PreprocConstExpr :: { NonTerm }
PreprocConstExpr
: PureExpr(PreprocConstExpr) { $1 }
| 'defined' '(' ID_CONST ')' { Fix $ PreprocDefined $3 }
: 'defined' '(' ID_CONST ')' { Fix $ PreprocDefined $3 }
| PureExpr(PreprocConstExpr) { $1 }

MacroParamList :: { [NonTerm] }
MacroParamList
Expand Down Expand Up @@ -355,10 +355,7 @@ Stmts

Stmt :: { NonTerm }
Stmt
: PreprocIfdef(Stmts) { $1 }
| PreprocIf(Stmts) { $1 }
| PreprocDefine Stmts PreprocUndef { Fix $ PreprocScopedDefine $1 (reverse $2) $3 }
| DeclStmt { $1 }
: DeclStmt { $1 }
| CompoundStmt { $1 }
| IfStmt { $1 }
| ForStmt { $1 }
Expand All @@ -376,6 +373,9 @@ Stmt
| return Expr ';' { Fix $ Return (Just $2) }
| switch '(' Expr ')' '{' SwitchCases '}' { Fix $ SwitchStmt $3 (reverse $6) }
| Comment { $1 }
| PreprocIfdef(Stmts) { $1 }
| PreprocIf(Stmts) { $1 }
| PreprocDefine Stmts PreprocUndef { Fix $ PreprocScopedDefine $1 (reverse $2) $3 }

IfStmt :: { NonTerm }
IfStmt
Expand Down Expand Up @@ -474,17 +474,21 @@ CompoundStmt
-- Expressions that are safe for use as macro body without () around it..
PreprocSafeExpr(x)
: LiteralExpr { $1 }
| '(' x ')' { Fix $ ParenExpr $2 }
| '(' QualType ')' x %prec CAST { Fix $ CastExpr $2 $4 }
| sizeof '(' Expr ')' { Fix $ SizeofExpr $3 }
| sizeof '(' QualType ')' { Fix $ SizeofType $3 }
| sizeof '(' Expr ')' { Fix $ SizeofExpr $3 }
| '(' QualType ')' x %prec CAST { Fix $ CastExpr $2 $4 }
| '(' x ')' { Fix $ ParenExpr $2 }

ConstExpr :: { NonTerm }
ConstExpr
: PureExpr(ConstExpr) { $1 }

PureExpr(x)
: PreprocSafeExpr(x) { $1 }
| '!' x { Fix $ UnaryExpr UopNot $2 }
| '~' x { Fix $ UnaryExpr UopNeg $2 }
| '-' x %prec NEG { Fix $ UnaryExpr UopMinus $2 }
| '&' x %prec ADDRESS { Fix $ UnaryExpr UopAddress $2 }
| x '!=' x { Fix $ BinaryExpr $1 BopNe $3 }
| x '==' x { Fix $ BinaryExpr $1 BopEq $3 }
| x '||' x { Fix $ BinaryExpr $1 BopOr $3 }
Expand All @@ -504,10 +508,6 @@ PureExpr(x)
| x '>=' x { Fix $ BinaryExpr $1 BopGe $3 }
| x '>>' x { Fix $ BinaryExpr $1 BopRsh $3 }
| x '?' x ':' x { Fix $ TernaryExpr $1 $3 $5 }
| '!' x { Fix $ UnaryExpr UopNot $2 }
| '~' x { Fix $ UnaryExpr UopNeg $2 }
| '-' x %prec NEG { Fix $ UnaryExpr UopMinus $2 }
| '&' x %prec ADDRESS { Fix $ UnaryExpr UopAddress $2 }

LiteralExpr :: { NonTerm }
LiteralExpr
Expand Down
2 changes: 1 addition & 1 deletion src/Language/Cimple/Tokens.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,7 +125,7 @@ data LexemeClass

| ErrorToken
| Eof
deriving (Enum, Bounded, Ord, Eq, Show, Generic)
deriving (Enum, Bounded, Ord, Eq, Show, Read, Generic)

instance FromJSON LexemeClass
instance ToJSON LexemeClass
177 changes: 171 additions & 6 deletions test/Language/Cimple/ParserSpec.hs
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,176 @@
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
module Language.Cimple.ParserSpec where

import Data.Fix (Fix (..))
import Test.Hspec (Spec, describe, it, shouldBe,
shouldSatisfy)
import qualified Data.ByteString.Lazy as LBS
import Data.Fix (Fix (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Cimple (AlexPosn (..), Lexeme (..),
LexemeClass (..), NodeF (..),
Scope (..))
import qualified Language.Cimple as Cimple
import Language.Cimple.IO (parseText)
import qualified Language.Happy as Happy
import Language.Happy.Arbitrary (Config, defConfig, genTokens)
import Test.Hspec (Spec, describe, it, shouldBe,
shouldNotBe, shouldSatisfy)
import Test.QuickCheck (Gen, forAll)

import Language.Cimple (AlexPosn (..), Lexeme (..),
LexemeClass (..), NodeF (..), Scope (..))
import Language.Cimple.IO (parseText)

sampleToken :: LexemeClass -> Text
sampleToken c = case c of
IdConst -> "ID_CONST"
IdFuncType -> "func_cb"
IdStdType -> "uint32_t"
IdSueType -> "Sue_Type"
IdVar -> "var"
KwBreak -> "break"
KwCase -> "case"
KwConst -> "const"
KwContinue -> "continue"
KwDefault -> "default"
KwDo -> "do"
KwElse -> "else"
KwEnum -> "enum"
KwExtern -> "extern"
KwFor -> "for"
KwGnuPrintf -> "gnu_printf"
KwGoto -> "goto"
KwIf -> "if"
KwNonNull -> "non_null"
KwNullable -> "nullable"
KwReturn -> "return"
KwSizeof -> "sizeof"
KwStatic -> "static"
KwStaticAssert -> "static_assert"
KwStruct -> "struct"
KwSwitch -> "switch"
KwTypedef -> "typedef"
KwUnion -> "union"
KwVla -> "VLA"
KwVoid -> "void"
KwWhile -> "while"
LitFalse -> "false"
LitTrue -> "true"
LitChar -> "'a'"
LitInteger -> "123"
LitString -> "\"str\""
LitSysInclude -> "<stdio.h>"
PctAmpersand -> "&"
PctAmpersandAmpersand -> "&&"
PctAmpersandEq -> "&="
PctArrow -> "->"
PctAsterisk -> "*"
PctAsteriskEq -> "*="
PctCaret -> "^"
PctCaretEq -> "^="
PctColon -> ":"
PctComma -> ","
PctEllipsis -> "..."
PctEMark -> "!"
PctEMarkEq -> "!="
PctEq -> "="
PctEqEq -> "=="
PctGreater -> ">"
PctGreaterEq -> ">="
PctGreaterGreater -> ">>"
PctGreaterGreaterEq -> ">>="
PctLBrace -> "{\n"
PctLBrack -> "["
PctLess -> "<"
PctLessEq -> "<="
PctLessLess -> "<<"
PctLessLessEq -> "<<="
PctLParen -> "("
PctMinus -> "-"
PctMinusEq -> "-="
PctMinusMinus -> "--"
PctPeriod -> "."
PctPercent -> "%"
PctPercentEq -> "%="
PctPipe -> "|"
PctPipeEq -> "|="
PctPipePipe -> "||"
PctPlus -> "+"
PctPlusEq -> "+="
PctPlusPlus -> "++"
PctQMark -> "?"
PctRBrace -> "}"
PctRBrack -> "]"
PctRParen -> ")"
PctSemicolon -> ";\n"
PctSlash -> "/"
PctSlashEq -> "/="
PctTilde -> "~"
PpDefine -> "\n#define"
PpDefined -> "\n#defined"
PpElif -> "\n#elif"
PpElse -> "\n#else"
PpEndif -> "\n#endif"
PpIf -> "\n#if"
PpIfdef -> "\n#ifdef"
PpIfndef -> "\n#ifndef"
PpInclude -> "\n#include"
PpNewline -> "\n"
PpUndef -> "\n#undef"
CmtBlock -> "/**"
CmtCommand -> "@param"
CmtAttr -> "[out]"
CmtEndDocSection -> "/** @} */"
CmtPrefix -> "//"
CmtIndent -> "*"
CmtStart -> "/*"
CmtStartCode -> "/*!"
CmtStartBlock -> "/***"
CmtStartDoc -> "/**"
CmtStartDocSection -> "/** @{"
CmtSpdxCopyright -> "Copyright ©"
CmtSpdxLicense -> "SPDX-License-Identifier:"
CmtCode -> "@code"
CmtWord -> "hello"
CmtRef -> "`ref`"
CmtEnd -> "*/\n"
IgnStart -> "\n//!TOKSTYLE-\n"
IgnBody -> "ignored stuff"
IgnEnd -> "\n//!TOKSTYLE+\n"

ErrorToken -> "!!ERROR!!"
Eof -> "!!EOF!!"


config :: Config LexemeClass
config = defConfig parseToken
where
parseToken :: Text -> LexemeClass
parseToken =
read
. Text.unpack
. (!! 2)
. concatMap (filter (not . Text.null) . Text.splitOn "\t")
. Text.splitOn " "

grammar :: Maybe Happy.Grammar
grammar = do
source <- Cimple.source
case Happy.runAlex (LBS.fromStrict source) Happy.parseGrammar of
Left err -> error err
Right ok -> return ok

arbitraryCode :: Happy.Grammar -> Gen Text
arbitraryCode g =
Text.intercalate " " . map sampleToken <$> genTokens config "TranslationUnit" g

arbitrarySpec :: Spec
arbitrarySpec = case grammar of
Nothing -> return ()
Just g ->
it "can handle arbitrary code" $
forAll (arbitraryCode g) $ \code -> do
case parseText code of
Right _ -> return ()
Left err -> err `shouldNotBe` ""


isRight1 :: Either a [b] -> Bool
Expand All @@ -18,6 +181,8 @@ isRight1 _ = False
spec :: Spec
spec = do
describe "C parsing" $ do
arbitrarySpec

it "should parse a simple function" $ do
let ast = parseText "int a(void) { return 3; }"
ast `shouldSatisfy` isRight1
Expand Down

0 comments on commit 9ca3810

Please sign in to comment.