diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## [0.13] - 2021-04-29 +### Added + - Add quotation support for attributes (Richard Marko) + - Add ranges to case labels as a GCC extension (Mark Barbone) +### Fixed + - #81 Missing braces cause dangling-else +### Changed + - Remove dependency on `symbol` package. + ## [0.12.2.1] - 2019-10-04 ### Added - Support for GHC 8.8.1. @@ -101,6 +110,9 @@ ### Changed - `Located` instances are also now automatically generated. +[0.13]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.2.1...language-c-quote-0.13 +[0.12.2.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.2...language-c-quote-0.12.2.1 +[0.12.2]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.1...language-c-quote-0.12.2 [0.12.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12...language-c-quote-0.12.1 [0.12]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7.2...language-c-quote-0.12 [0.11.7.3]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7.2...language-c-quote-0.11.7.3 diff --git a/Language/C/Parser/Lexer.x b/Language/C/Parser/Lexer.x --- a/Language/C/Parser/Lexer.x +++ b/Language/C/Parser/Lexer.x @@ -40,7 +40,6 @@ import qualified Data.Map as Map import Data.Ratio ((%)) import qualified Data.Set as Set -import Data.Symbol import Data.Maybe (fromMaybe) import Text.PrettyPrint.Mainland @@ -124,6 +123,8 @@ "$comment:" / { allowAnti } { lexAnti Tanti_comment } "$init:" / { allowAnti } { lexAnti Tanti_init } "$inits:" / { allowAnti } { lexAnti Tanti_inits } + "$attr:" / { allowAnti } { lexAnti Tanti_attr } + "$attrs:" / { allowAnti } { lexAnti Tanti_attrs } "$" / { allowAnti } { lexAnti Tanti_exp } -- @@ -317,7 +318,7 @@ s <- case c of '(' -> lexExpression 0 "" _ | isIdStartChar c -> lexIdChars [c] - | otherwise -> lexerError beg (text "illegal anitquotation") + | otherwise -> lexerError beg (text "illegal antiquotation") return $ locateTok beg end (antiTok s) where lexIdChars :: String -> P String diff --git a/Language/C/Parser/Parser.y b/Language/C/Parser/Parser.y --- a/Language/C/Parser/Parser.y +++ b/Language/C/Parser/Parser.y @@ -203,6 +203,9 @@ '__typeof__' { L _ T.Ttypeof } '__restrict' { L _ T.T__restrict } + ANTI_ATTR { L _ (T.Tanti_attr _) } + ANTI_ATTRS { L _ (T.Tanti_attrs _) } + -- -- Clang blocks -- @@ -322,6 +325,8 @@ %name parseUnit translation_unit %name parseFunc function_definition +%name parseAttr attrib + -- -- Objective-C -- @@ -2061,9 +2066,19 @@ labeled_statement : identifier ':' error {% expected ["statement"] (Just "label") } | identifier ':' statement { Label $1 [] $3 ($1 `srcspan` $3) } - | 'case' constant_expression error {% expected ["`:'"] Nothing } + | 'case' constant_expression error + {% do { gcc_enabled <- useGccExts + ; let options = if gcc_enabled then ["`:'", "`...'"] else ["`:'"] + ; expected options Nothing } } | 'case' constant_expression ':' error {% expected ["statement"] Nothing } | 'case' constant_expression ':' statement { Case $2 $4 ($1 `srcspan` $4) } + | 'case' constant_expression '...' constant_expression error + {% expected ["`:'"] Nothing } + | 'case' constant_expression '...' constant_expression ':' error + {% expected ["statement"] Nothing } + | 'case' constant_expression '...' constant_expression ':' statement + {% gccOnly "To use ranges in case statements, enable GCC extensions" + $ CaseRange $2 $4 $6 ($1 `srcspan` $6) } | 'default' error {% expected ["`:'"] (Just "`default'")} | 'default' ':' error {% expected ["statement"] Nothing } | 'default' ':' statement { Default $3 ($1 `srcspan` $3) } @@ -2327,6 +2342,8 @@ attribute_rlist : attrib { rsingleton $1 } | attribute_rlist ',' attrib { rcons $3 $1 } + | ANTI_ATTRS + { rsingleton $ AntiAttrs (getANTI_ATTRS $1) (srclocOf $1) } attrib :: { Attr } attrib : @@ -2334,6 +2351,8 @@ { Attr $1 [] (srclocOf $1)} | attrib_name '(' argument_expression_list ')' { Attr $1 $3 ($1 `srcspan` $4) } + | ANTI_ATTR + { AntiAttr (getANTI_ATTR $1) (srclocOf $1) } attrib_name :: { Id } attrib_name : @@ -3391,6 +3410,8 @@ getANTI_COMMENT (L _ (T.Tanti_comment v)) = v getANTI_INIT (L _ (T.Tanti_init v)) = v getANTI_INITS (L _ (T.Tanti_inits v)) = v +getANTI_ATTR (L _ (T.Tanti_attr v)) = v +getANTI_ATTRS (L _ (T.Tanti_attrs v)) = v -- -- Objective-C @@ -4008,6 +4029,13 @@ cuda_enabled <- useCUDAExts unless cuda_enabled $ throw $ ParserException loc $ text errMsg + +gccOnly :: Located a => String -> a -> P a +gccOnly errMsg x = do + gcc_enabled <- useGccExts + unless gcc_enabled $ + throw $ ParserException (locOf x) $ text errMsg + pure x mkBlock :: [BlockItem] -> SrcLoc -> Stm mkBlock items@[BlockStm AntiStms{}] sloc = Block items sloc diff --git a/Language/C/Parser/Tokens.hs b/Language/C/Parser/Tokens.hs --- a/Language/C/Parser/Tokens.hs +++ b/Language/C/Parser/Tokens.hs @@ -166,6 +166,8 @@ | Tanti_comment String | Tanti_init String | Tanti_inits String + | Tanti_attr String + | Tanti_attrs String -- C99 | TBool @@ -314,6 +316,8 @@ show (Tanti_comment s) = showAnti "comment" s show (Tanti_init s) = showAnti "init" s show (Tanti_inits s) = showAnti "inits" s + show (Tanti_attr s) = showAnti "attr" s + show (Tanti_attrs s) = showAnti "attrs" s -- -- Objective C diff --git a/Language/C/Pretty.hs b/Language/C/Pretty.hs --- a/Language/C/Pretty.hs +++ b/Language/C/Pretty.hs @@ -473,6 +473,9 @@ ppr (Attr ident args _) = ppr ident <> parens (commasep (map ppr args)) + ppr (AntiAttr v _) = pprAnti "attr" v + ppr (AntiAttrs v _) = pprAnti "attrs" v + pprList [] = empty pprList attrs = text "__attribute__" <> parens (parens (commasep (map ppr attrs))) @@ -582,6 +585,10 @@ srcloc sloc <> indent (-2) (line <> text "case" <+> ppr e <> colon) ppr stm + ppr (CaseRange e1 e2 stm sloc) = + srcloc sloc <> + indent (-2) (line <> text "case" <+> ppr e1 <+> text "..." <+> ppr e2 <> colon) ppr stm + ppr (Default stm sloc) = srcloc sloc <> indent (-2) (line <> text "default" <> colon) ppr stm @@ -600,9 +607,15 @@ text "if" <+> parens (ppr test) <> pprThen then' (fmap pprElse maybe_else) where + isIf :: Stm -> Bool + isIf If{} = True + isIf (Comment _ stm _) = isIf stm + isIf _ = False + pprThen :: Stm -> Maybe Doc -> Doc pprThen stm@(Block {}) rest = space <> ppr stm <+> maybe empty id rest - pprThen stm@(If {}) rest = space <> ppr [BlockStm stm] <+> maybe empty id rest + pprThen stm rest + | isIf stm = space <> ppr [BlockStm stm] <+> maybe empty id rest pprThen stm Nothing = nest 4 (line <> ppr stm) pprThen stm (Just rest) = nest 4 (line <> ppr stm) rest diff --git a/Language/C/Quote.hs b/Language/C/Quote.hs --- a/Language/C/Quote.hs +++ b/Language/C/Quote.hs @@ -18,7 +18,6 @@ -- imports to any module using the quasiquoters provided by this package: -- -- > import qualified Data.Loc --- > import qualified Data.Symbol -- > import qualified Language.C.Syntax -- -- These modules may also be imported unqualified, of course. The quasiquoters diff --git a/Language/C/Quote/Base.hs b/Language/C/Quote/Base.hs --- a/Language/C/Quote/Base.hs +++ b/Language/C/Quote/Base.hs @@ -276,6 +276,17 @@ qqInitGroupListE (ini : inis) = Just [|$(dataToExpQ qqExp ini) : $(dataToExpQ qqExp inis)|] +qqAttrE :: C.Attr -> Maybe (Q Exp) +qqAttrE (C.AntiAttr v _) = Just $ antiVarE v +qqAttrE _ = Nothing + +qqAttrListE :: [C.Attr] -> Maybe (Q Exp) +qqAttrListE [] = Just [|[]|] +qqAttrListE (C.AntiAttrs v _ : attrs) = + Just [|$(antiVarE v) ++ $(dataToExpQ qqExp attrs)|] +qqAttrListE (field : fields) = + Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|] + qqFieldGroupE :: C.FieldGroup -> Maybe (Q Exp) qqFieldGroupE (C.AntiSdecl v _) = Just $ antiVarE v qqFieldGroupE _ = Nothing @@ -502,6 +513,8 @@ `extQ` qqInitializerListE `extQ` qqInitGroupE `extQ` qqInitGroupListE + `extQ` qqAttrE + `extQ` qqAttrListE `extQ` qqFieldGroupE `extQ` qqFieldGroupListE `extQ` qqCEnumE @@ -593,6 +606,18 @@ qqInitGroupListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] +qqAttrP :: C.Attr -> Maybe (Q Pat) +qqAttrP (C.AntiAttr v _) = Just $ antiVarP v +qqAttrP _ = Nothing + +qqAttrListP :: [C.Attr] -> Maybe (Q Pat) +qqAttrListP [] = Just $ listP [] +qqAttrListP [C.AntiAttrs v _] = Just $ antiVarP v +qqAttrListP (C.AntiAttrs{} : _ : _) = + error "Antiquoted list of attrs must be last item in quoted list" +qqAttrListP (ini : inis) = + Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] + qqFieldGroupP :: C.FieldGroup -> Maybe (Q Pat) qqFieldGroupP (C.AntiSdecl v _) = Just $ antiVarP v qqFieldGroupP _ = Nothing @@ -727,6 +752,8 @@ `extQ` qqInitializerListP `extQ` qqInitGroupP `extQ` qqInitGroupListP + `extQ` qqAttrP + `extQ` qqAttrListP `extQ` qqFieldGroupP `extQ` qqCEnumP `extQ` qqCEnumListP diff --git a/Language/C/Quote/GCC.hs b/Language/C/Quote/GCC.hs --- a/Language/C/Quote/GCC.hs +++ b/Language/C/Quote/GCC.hs @@ -25,7 +25,8 @@ citem, citems, cunit, - cfun + cfun, + cattr ) where import qualified Language.C.Parser as P @@ -40,7 +41,7 @@ typenames = [] cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter -citem, citems, ctyquals, cty, cunit :: QuasiQuoter +citem, citems, ctyquals, cty, cunit, cattr :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum @@ -57,3 +58,4 @@ ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit +cattr = quasiquote exts typenames P.parseAttr diff --git a/Language/C/Smart.hs b/Language/C/Smart.hs --- a/Language/C/Smart.hs +++ b/Language/C/Smart.hs @@ -16,7 +16,6 @@ #if !MIN_VERSION_template_haskell(2,7,0) import qualified Data.Loc -import qualified Data.Symbol import qualified Language.C.Syntax #endif /* !MIN_VERSION_template_haskell(2,7,0) */ diff --git a/Language/C/Syntax-instances.hs b/Language/C/Syntax-instances.hs --- a/Language/C/Syntax-instances.hs +++ b/Language/C/Syntax-instances.hs @@ -114,6 +114,8 @@ locOf (AntiEnums _ l) = locOf l instance Located Attr where locOf (Attr _ _ l) = locOf l + locOf (AntiAttr _ l) = locOf l + locOf (AntiAttrs _ l) = locOf l instance Located Param where locOf (Param _ _ _ l) = locOf l locOf (AntiParam _ l) = locOf l @@ -147,6 +149,7 @@ instance Located Stm where locOf (Label _ _ _ l) = locOf l locOf (Case _ _ l) = locOf l + locOf (CaseRange _ _ _ l) = locOf l locOf (Default _ l) = locOf l locOf (Exp _ l) = locOf l locOf (Block _ l) = locOf l @@ -420,6 +423,8 @@ reloc l (AntiEnums x0 _) = (AntiEnums x0 (fromLoc l)) instance Relocatable Attr where reloc l (Attr x0 x1 _) = (Attr x0 x1 (fromLoc l)) + reloc l (AntiAttr x0 _) = (AntiAttr x0 (fromLoc l)) + reloc l (AntiAttrs x0 _) = (AntiAttrs x0 (fromLoc l)) instance Relocatable Param where reloc l (Param x0 x1 x2 _) = (Param x0 x1 x2 (fromLoc l)) reloc l (AntiParam x0 _) = (AntiParam x0 (fromLoc l)) @@ -457,6 +462,7 @@ instance Relocatable Stm where reloc l (Label x0 x1 x2 _) = (Label x0 x1 x2 (fromLoc l)) reloc l (Case x0 x1 _) = (Case x0 x1 (fromLoc l)) + reloc l (CaseRange x0 x1 x2 _) = (CaseRange x0 x1 x2 (fromLoc l)) reloc l (Default x0 _) = (Default x0 (fromLoc l)) reloc l (Exp x0 _) = (Exp x0 (fromLoc l)) reloc l (Block x0 _) = (Block x0 (fromLoc l)) diff --git a/Language/C/Syntax.hs b/Language/C/Syntax.hs --- a/Language/C/Syntax.hs +++ b/Language/C/Syntax.hs @@ -195,6 +195,8 @@ deriving (Eq, Ord, Show, Data, Typeable) data Attr = Attr Id [Exp] !SrcLoc + | AntiAttr String !SrcLoc + | AntiAttrs String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Param = Param (Maybe Id) DeclSpec Decl !SrcLoc @@ -236,6 +238,7 @@ data Stm = Label Id [Attr] Stm !SrcLoc | Case Exp Stm !SrcLoc + | CaseRange Exp Exp Stm !SrcLoc | Default Stm !SrcLoc | Exp (Maybe Exp) !SrcLoc | Block [BlockItem] !SrcLoc diff --git a/language-c-quote.cabal b/language-c-quote.cabal --- a/language-c-quote.cabal +++ b/language-c-quote.cabal @@ -1,5 +1,5 @@ name: language-c-quote -version: 0.12.2.1 +version: 0.13 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE @@ -15,7 +15,8 @@ category: Language synopsis: C/CUDA/OpenCL/Objective-C quasiquoting library. tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, - GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.1 + GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, + GHC==9.0.1 description: This package provides a general parser for the C language, including most GCC @@ -36,7 +37,7 @@ manual: True library - default-language: Haskell98 + default-language: Haskell2010 build-depends: array >= 0.2 && < 0.6, @@ -48,19 +49,21 @@ filepath >= 1.2 && < 1.5, mainland-pretty >= 0.7 && < 0.8, mtl >= 2.0 && < 3, - srcloc >= 0.4 && < 0.6, + srcloc >= 0.4 && < 0.7, syb >= 0.3 && < 0.8, - symbol >= 0.1 && < 0.3, template-haskell if flag(full-haskell-antiquotes) if impl(ghc < 7.8) build-depends: safe <= 0.3.9 - if impl(ghc >= 7.6) - build-depends: haskell-src-meta >= 0.4 && < 0.9 + if impl(ghc >= 8.0) && impl(ghc < 8.1) + build-depends: haskell-src-meta >= 0.4 && < 0.8.7 else - build-depends: haskell-src-meta >= 0.4 && < 0.7 + if impl(ghc >= 7.6) + build-depends: haskell-src-meta >= 0.4 && < 0.9 + else + build-depends: haskell-src-meta >= 0.4 && < 0.7 else build-depends: haskell-exp-parser >= 0.1 && < 0.2 @@ -105,10 +108,11 @@ main-is: Main.hs other-modules: CUDA + GCC Objc MainCPP - default-language: Haskell98 + default-language: Haskell2010 build-depends: HUnit >= 1.2 && < 1.7, @@ -116,8 +120,7 @@ bytestring >= 0.9 && < 0.11, language-c-quote, mainland-pretty >= 0.7 && < 0.8, - srcloc >= 0.4 && < 0.6, - symbol >= 0.1 && < 0.3, + srcloc >= 0.4 && < 0.7, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3 && < 0.4 diff --git a/tests/unit/GCC.hs b/tests/unit/GCC.hs new file mode 100644 --- /dev/null +++ b/tests/unit/GCC.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE QuasiQuotes #-} + +module GCC ( + gccTests + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit (Assertion, assert, (@?=)) + +import qualified Data.ByteString.Char8 as B +import Data.Char (isSpace) +import Data.Loc (SrcLoc, noLoc, startPos) +import Control.Exception (SomeException) +import Language.C.Quote.GCC +import Language.C.Smart () +import qualified Language.C.Syntax as C +import qualified Language.C.Parser as P +import Text.PrettyPrint.Mainland +import Text.PrettyPrint.Mainland.Class + +gccTests :: Test +gccTests = testGroup "GCC attribute quotations" + [ testCase "attr antiquote" test_attr + , testCase "attrs antiquote" test_attrs + , testCase "attrs antiquote pretty" test_attr_p + , testCase "case ranges quote" test_case_ranges + , testCase "case ranges pretty" test_case_ranges_p + ] + where + test_attr :: Assertion + test_attr = + [cedecl| int test __attribute__(($attr:a,$attr:b));|] + @?= + [cedecl| int test __attribute__((section(".sram2"), noinit));|] + where + a = [cattr| section(".sram2") |] + b = [cattr| noinit |] + + test_attrs :: Assertion + test_attrs = + [cedecl| int test __attribute__(($attrs:as));|] + @?= + [cedecl| int test __attribute__((section(".sram2"), noinit));|] + where + a = [cattr| section(".sram2") |] + b = [cattr| noinit |] + as = [ a, b ] + + test_attr_p :: Assertion + test_attr_p = + pretty 80 (ppr [cattr|section(".sram2")|]) @?= "section(\".sram2\")" + + test_case_ranges :: Assertion + test_case_ranges = assert $ case [cstm| case 10 ... 20: ; |] of + C.CaseRange 10 20 (C.Exp Nothing _) _ -> True + _ -> False + + test_case_ranges_p :: Assertion + test_case_ranges_p = + pretty 80 (ppr [cstm| case 10 ... 20: ; |]) @?= "\ncase 10 ... 20:\n;" diff --git a/tests/unit/Main.hs b/tests/unit/Main.hs --- a/tests/unit/Main.hs +++ b/tests/unit/Main.hs @@ -11,10 +11,12 @@ import Data.Loc (SrcLoc, noLoc, startPos) import Control.Exception (SomeException) import Language.C.Quote.C +import qualified Language.C.Quote.GCC as GCC import qualified Language.C.Syntax as C import qualified Language.C.Parser as P import MainCPP import Numeric (showHex) +import GCC (gccTests) import Objc (objcTests, objcRegressionTests) import CUDA (cudaTests) import Text.PrettyPrint.Mainland @@ -30,6 +32,7 @@ , cPatternAntiquotationTests , statementCommentTests , regressionTests + , gccTests , objcTests , objcRegressionTests , cudaTests @@ -490,7 +493,9 @@ regressionTests :: Test regressionTests = testGroup "Regressions" - [ issue68 + [ issue81 + , issue76 + , issue68 , issue64 , testCase "pragmas" test_pragmas , issue48 @@ -518,6 +523,28 @@ ] noLoc ] + + issue81 :: Test + issue81 = testCase "Issue #81"$ + showCompact [cstm|if (x > 1) { /* comment */ if (x > 2) x++; }|] + @?= + "if (x > 1) { /* comment */ if (x > 2) x++; }" + + issue76 :: Test + issue76 = testCase "Issue #76" $ + [cunit| + /* AAA */ + struct A { int foo; }; + /* BBB */ + struct B { int bar; }; + |] + @?= + [cunit| + /* AAA */ + struct A { int foo; }; + $comment:(" BBB ") + struct B { int bar; }; + |] issue68 :: Test issue68 = testCase "Issue #68"$