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 @@ -490,10 +490,7 @@ | '(' expression_nlt error {% unclosed ($1 <--> $2) "(" } | '(' compound_statement ')' - { let Block items _ = $2 - in - StmExpr items ($1 `srcspan` $3) - } + { StmExpr (mkBlockItems $2) ($1 `srcspan` $3) } | ANTI_ESC { AntiEscExp (getANTI_ESC $1) (srclocOf $1) } | ANTI_EXP @@ -758,10 +755,7 @@ | '(' expression_nlt error {% unclosed ($1 <--> $2) "(" } | '(' compound_statement ')' - { let Block items _ = $2 - in - StmExpr items ($1 `srcspan` $3) - } + { StmExpr (mkBlockItems $2) ($1 `srcspan` $3) } | ANTI_ESC { AntiEscExp (getANTI_ESC $1) (srclocOf $1) } | ANTI_EXP @@ -2074,9 +2068,9 @@ compound_statement :: { Stm } compound_statement: '{' begin_scope end_scope '}' - { Block [] ($1 `srcspan` $4) } + { mkBlock [] ($1 `srcspan` $4) } | '{' begin_scope block_item_list end_scope '}' - { Block $3 ($1 `srcspan` $5) } + { mkBlock $3 ($1 `srcspan` $5) } | '{' begin_scope error {% unclosed (locOf $3) "{" } @@ -2220,7 +2214,7 @@ declaration_specifiers declarator compound_statement {% do{ let (dspec, declRoot) = $1 ; let (ident, declToDecl) = $2 - ; let Block blockItems _ = $3 + ; let blockItems = mkBlockItems $3 ; let decl = declToDecl declRoot ; case decl of { Proto protoDecl args _ -> return $ @@ -2240,7 +2234,7 @@ {% do{ let (dspec, declRoot) = $1 ; let (ident, declToDecl) = $2 ; let argDecls = $3 - ; let Block blockItems _ = $4 + ; let blockItems = mkBlockItems $4 ; let decl = declToDecl declRoot ; case decl of { OldProto protoDecl args _ -> return $ @@ -2448,23 +2442,22 @@ block_literal : '^' attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $3) "To use blocks, enable the blocks language extension" - ; let Block items _ = $3 + ; let items = mkBlockItems $3 ; return $ BlockLit (BlockVoid (srclocOf $1)) $2 items ($1 `srcspan` $3) } } | '^' '(' parameter_list ')' attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $6) "To use blocks, enable blocks language extension" - ; let Block items _ = $6 + ; let items = mkBlockItems $6 ; return $ BlockLit (BlockParam $3 ($2 `srcspan` $4)) $5 items ($1 `srcspan` $6) } } | '^' specifier_qualifier_list abstract_declarator attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $5) "To use blocks, enable blocks language extension" - ; let { decl = $3 (declRoot $2) - ; Block items _ = $5 - } - ; dspec <- mkDeclSpec $2 - ; let typeLoc = dspec `srcspan` decl + ; let decl = $3 (declRoot $2) + ; let items = mkBlockItems $5 + ; dspec <- mkDeclSpec $2 + ; let typeLoc = dspec `srcspan` decl ; return $ BlockLit (BlockType (Type dspec decl typeLoc) typeLoc) $4 items ($1 `srcspan` $5) } } @@ -2527,15 +2520,15 @@ objc_at_statement :: { Stm } objc_at_statement : '@' 'try' compound_statement objc_catch_statement_rlist '@' 'finally' compound_statement - { let { Block tryItems _ = $3 - ; Block finallyItems _ = $7 + { let { tryItems = mkBlockItems $3 + ; finallyItems = mkBlockItems $7 } in ObjCTry tryItems (rev $4) (Just finallyItems) ($1 `srcspan` $7) } | '@' 'try' compound_statement objc_catch_statement_rlist - {% do { let { Block tryItems _ = $3 - ; catchStmts = rev $4 + {% do { let { tryItems = mkBlockItems $3 + ; catchStmts = rev $4 } ; when (null catchStmts) $ throw $ ParserException ($1 <--> $3) $ @@ -2556,12 +2549,12 @@ | '@' 'throw' error {% expected ["';'", "expression"] Nothing } | '@' 'synchronized' '(' expression ')' compound_statement - { let Block items _ = $6 + { let items = mkBlockItems $6 in ObjCSynchronized $4 items ($1 `srcspan` $6) } | '@' 'autoreleasepool' compound_statement - { let Block items _ = $3 + { let items = mkBlockItems $3 in ObjCAutoreleasepool items ($1 `srcspan` $3) } @@ -2571,11 +2564,11 @@ {- empty -} { rnil } | objc_catch_statement_rlist '@' 'catch' '(' parameter_declaration ')' compound_statement - { let Block items _ = $7 + { let items = mkBlockItems $7 in rcons (ObjCCatch (Just $5) items ($2 `srcspan` $7)) $1 } | objc_catch_statement_rlist '@' 'catch' '(' '...' ')' compound_statement - { let Block items _ = $7 + { let items = mkBlockItems $7 in rcons (ObjCCatch Nothing items ($2 `srcspan` $7)) $1 } @@ -3224,14 +3217,14 @@ objc_method_definition :: { Definition } objc_method_definition : objc_method_proto semi compound_statement - { let Block stmts loc = $3 + { let stmts = mkBlockItems $3 in - ObjCMethDef $1 stmts ($1 `srcspan` loc) + ObjCMethDef $1 stmts ($1 `srcspan` $3) } - | objc_method_proto compound_statement - { let Block stmts loc = $2 + | objc_method_proto compound_statement + { let stmts = mkBlockItems $2 in - ObjCMethDef $1 stmts ($1 `srcspan` loc) + ObjCMethDef $1 stmts ($1 `srcspan` $2) } | ANTI_OBJC_METHOD_DEF { AntiObjCMeth (getANTI_OBJC_METHOD_DEF $1) (srclocOf $1) } @@ -3259,7 +3252,7 @@ cuda_lambda_expression :: { Exp } cuda_lambda_expression : cuda_lambda_introducer cuda_lambda_declarator compound_statement {% do { assertCudaEnabled ($1 <--> $3) "To use lambda-expressions, enable support for CUDA" - ; let Block items _ = $3 + ; let items = mkBlockItems $3 ; return $ Lambda $1 $2 items ($1 `srcspan` $3) } } @@ -4000,6 +3993,14 @@ cuda_enabled <- useCUDAExts unless cuda_enabled $ throw $ ParserException loc $ text errMsg + +mkBlock :: [BlockItem] -> SrcLoc -> Stm +mkBlock [BlockStm stm] _ = stm +mkBlock items sloc = Block items sloc + +mkBlockItems :: Stm -> [BlockItem] +mkBlockItems (Block items _) = items +mkBlockItems stm = [BlockStm stm] mkCommentStm :: L T.Token -> Stm -> Stm mkCommentStm tok stm = Comment (getCOMMENT tok) stm (srclocOf tok) diff --git a/Language/C/Pretty.hs b/Language/C/Pretty.hs --- a/Language/C/Pretty.hs +++ b/Language/C/Pretty.hs @@ -47,7 +47,7 @@ -> b -- ^ right argument -> Doc infixop prec op l r = - parensIf (prec > opPrec) $ + parensOp prec op $ pprPrec leftPrec l <+> ppr op <+/> pprPrec rightPrec r where leftPrec | opAssoc == RightAssoc = opPrec + 1 @@ -107,6 +107,12 @@ class CFixity a where fixity :: a -> Fixity + parensOp :: Int -> a -> Doc -> Doc + parensOp prec op = + parensIf (prec > opPrec) + where + Fixity _ opPrec = fixity op + -- -- Fixities are taken from Table 2-1 in Section 2.12 of K&R (2nd ed.) -- @@ -154,6 +160,35 @@ fixity Lsh = infixl_ 11 fixity Rsh = infixl_ 11 + parensOp prec op = + go op + where + go :: BinOp -> Doc -> Doc + go Add | isBitwiseOp = parens + go Sub | isBitwiseOp = parens + go Land | isOp Lor = parens + go Lor | isOp Land = parens + go And | isOp Or = parens + | isOp Xor = parens + go Or | isOp And = parens + | isOp Xor = parens + go Xor | isOp And = parens + | isOp Or = parens + go _ = parensIf (prec > opPrec) + + isBitwiseOp :: Bool + isBitwiseOp = isOp And || isOp Or || isOp Xor + + -- Return 'True' if we are potentially an immediate subterm of the + -- binary operator op'. We make this determination based of the value of + -- @prec@. + isOp :: BinOp -> Bool + isOp op' = prec == op'Prec || prec == op'Prec + 1 + where + Fixity _ op'Prec = fixity op' + + Fixity _ opPrec = fixity op + instance CFixity AssignOp where fixity _ = infixr_ 2 @@ -555,36 +590,40 @@ ppr (If test then' maybe_else sloc) = srcloc sloc <> text "if" <+> parens (ppr test) <> - pprStm then' (fmap pprElse maybe_else) + pprThen then' (fmap pprElse maybe_else) where - pprElse :: Stm -> Doc - pprElse else' = text "else" <> pprStm else' Nothing + 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 Nothing = nest 4 (line <> ppr stm) + pprThen stm (Just rest) = nest 4 (line <> ppr stm) rest - pprStm :: Stm -> Maybe Doc -> Doc - pprStm stm@(Block {}) rest = space <> ppr stm <+> maybe empty id rest - pprStm stm@(If {}) rest = space <> ppr stm <+> maybe empty id rest - pprStm stm Nothing = nest 4 (line <> ppr stm) - pprStm stm (Just rest) = nest 4 (line <> ppr stm) rest + pprElse :: Stm -> Doc + pprElse stm = + text "else" <> go stm + where + go :: Stm -> Doc + go (Block {}) = space <> ppr stm + go (If {}) = space <> ppr stm + go _stm = nest 4 (line <> ppr stm) ppr (Switch e stm sloc) = srcloc sloc <> - text "switch" <+> parens (ppr e) <+/> ppr stm + text "switch" <+> parens (ppr e) <> pprBlock stm ppr (While e stm sloc) = srcloc sloc <> - text "while" <+> parens (ppr e) <+/> ppr stm + text "while" <+> parens (ppr e) <> pprBlock stm ppr (DoWhile stm e sloc) = srcloc sloc <> - text "do" <+/> ppr stm <+/> text "while" <> parens (ppr e) <> semi + text "do" <> pprBlock stm <+/> text "while" <> parens (ppr e) <> semi ppr (For ini test post stm sloc) = srcloc sloc <> text "for" <+> (parens . semisep) [either ppr ppr ini, ppr test, ppr post] <> - case stm of - Block {} -> space <> ppr stm - _ -> nest 4 $ line <> ppr stm + pprBlock stm ppr (Goto ident sloc) = srcloc sloc <> @@ -681,6 +720,11 @@ srcloc sloc <> text "@autoreleasepool" ppr block + +pprBlock :: Stm -> Doc +pprBlock stm@(Block {}) = space <> ppr stm +pprBlock stm@(If {}) = space <> ppr [BlockStm stm] +pprBlock stm = nest 4 $ line <> ppr stm instance Pretty BlockItem where ppr (BlockDecl decl) = ppr decl <> semi diff --git a/dist/build/Language/C/Parser/Lexer.hs b/dist/build/Language/C/Parser/Lexer.hs --- a/dist/build/Language/C/Parser/Lexer.hs +++ b/dist/build/Language/C/Parser/Lexer.hs @@ -574,8 +574,9 @@ alex_action_125 = token TCUDA3gt {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} {-# LINE 1 "" #-} -{-# LINE 8 "" #-} +{-# LINE 9 "" #-} # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4 @@ -621,7 +622,26 @@ -{-# LINE 8 "" #-} +{-# LINE 9 "" #-} +{-# LINE 1 "/home/mainland/software/haskell-platform-7.10.3/build/ghc-bindist/local/lib/ghc-7.10.3/include/ghcversion.h" #-} + + + + + + + + + + + + + + + + + +{-# LINE 9 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE diff --git a/dist/build/Language/C/Parser/Parser.hs b/dist/build/Language/C/Parser/Parser.hs --- a/dist/build/Language/C/Parser/Parser.hs +++ b/dist/build/Language/C/Parser/Parser.hs @@ -33,8 +33,9 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts import Control.Applicative(Applicative(..)) +import Control.Monad (ap) --- parser produced by Happy Version 1.19.4 +-- parser produced by Happy Version 1.19.5 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -2672,9 +2673,7 @@ case happyOut142 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn36 - (let Block items _ = happy_var_2 - in - StmExpr items (happy_var_1 `srcspan` happy_var_3) + (StmExpr (mkBlockItems happy_var_2) (happy_var_1 `srcspan` happy_var_3) )}}} happyReduce_88 = happySpecReduce_1 7# happyReduction_88 @@ -3622,9 +3621,7 @@ case happyOut142 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn59 - (let Block items _ = happy_var_2 - in - StmExpr items (happy_var_1 `srcspan` happy_var_3) + (StmExpr (mkBlockItems happy_var_2) (happy_var_1 `srcspan` happy_var_3) )}}} happyReduce_189 = happySpecReduce_1 30# happyReduction_189 @@ -7407,7 +7404,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn142 - (Block [] (happy_var_1 `srcspan` happy_var_4) + (mkBlock [] (happy_var_1 `srcspan` happy_var_4) ) `HappyStk` happyRest}} happyReduce_594 = happyReduce 5# 113# happyReduction_594 @@ -7421,7 +7418,7 @@ case happyOut143 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_5 of { happy_var_5 -> happyIn142 - (Block happy_var_3 (happy_var_1 `srcspan` happy_var_5) + (mkBlock happy_var_3 (happy_var_1 `srcspan` happy_var_5) ) `HappyStk` happyRest}}} happyReduce_595 = happyMonadReduce 3# 113# happyReduction_595 @@ -8048,7 +8045,7 @@ case happyOut142 happy_x_3 of { happy_var_3 -> ( do{ let (dspec, declRoot) = happy_var_1 ; let (ident, declToDecl) = happy_var_2 - ; let Block blockItems _ = happy_var_3 + ; let blockItems = mkBlockItems happy_var_3 ; let decl = declToDecl declRoot ; case decl of { Proto protoDecl args _ -> return $ @@ -8078,7 +8075,7 @@ ( do{ let (dspec, declRoot) = happy_var_1 ; let (ident, declToDecl) = happy_var_2 ; let argDecls = happy_var_3 - ; let Block blockItems _ = happy_var_4 + ; let blockItems = mkBlockItems happy_var_4 ; let decl = declToDecl declRoot ; case decl of { OldProto protoDecl args _ -> return $ @@ -8708,7 +8705,7 @@ case happyOut160 happy_x_2 of { happy_var_2 -> case happyOut142 happy_x_3 of { happy_var_3 -> ( do { assertBlocksEnabled (happy_var_1 <--> happy_var_3) "To use blocks, enable the blocks language extension" - ; let Block items _ = happy_var_3 + ; let items = mkBlockItems happy_var_3 ; return $ BlockLit (BlockVoid (srclocOf happy_var_1)) happy_var_2 items (happy_var_1 `srcspan` happy_var_3) })}}} ) (\r -> happyReturn (happyIn180 r)) @@ -8728,7 +8725,7 @@ case happyOut160 happy_x_5 of { happy_var_5 -> case happyOut142 happy_x_6 of { happy_var_6 -> ( do { assertBlocksEnabled (happy_var_1 <--> happy_var_6) "To use blocks, enable blocks language extension" - ; let Block items _ = happy_var_6 + ; let items = mkBlockItems happy_var_6 ; return $ BlockLit (BlockParam happy_var_3 (happy_var_2 `srcspan` happy_var_4)) happy_var_5 items (happy_var_1 `srcspan` happy_var_6) })}}}}}} ) (\r -> happyReturn (happyIn180 r)) @@ -8746,11 +8743,10 @@ case happyOut160 happy_x_4 of { happy_var_4 -> case happyOut142 happy_x_5 of { happy_var_5 -> ( do { assertBlocksEnabled (happy_var_1 <--> happy_var_5) "To use blocks, enable blocks language extension" - ; let { decl = happy_var_3 (declRoot happy_var_2) - ; Block items _ = happy_var_5 - } - ; dspec <- mkDeclSpec happy_var_2 - ; let typeLoc = dspec `srcspan` decl + ; let decl = happy_var_3 (declRoot happy_var_2) + ; let items = mkBlockItems happy_var_5 + ; dspec <- mkDeclSpec happy_var_2 + ; let typeLoc = dspec `srcspan` decl ; return $ BlockLit (BlockType (Type dspec decl typeLoc) typeLoc) happy_var_4 items (happy_var_1 `srcspan` happy_var_5) })}}}}} ) (\r -> happyReturn (happyIn180 r)) @@ -8855,8 +8851,8 @@ case happyOut186 happy_x_4 of { happy_var_4 -> case happyOut142 happy_x_7 of { happy_var_7 -> happyIn185 - (let { Block tryItems _ = happy_var_3 - ; Block finallyItems _ = happy_var_7 + (let { tryItems = mkBlockItems happy_var_3 + ; finallyItems = mkBlockItems happy_var_7 } in ObjCTry tryItems (rev happy_var_4) (Just finallyItems) (happy_var_1 `srcspan` happy_var_7) @@ -8871,8 +8867,8 @@ = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut142 happy_x_3 of { happy_var_3 -> case happyOut186 happy_x_4 of { happy_var_4 -> - ( do { let { Block tryItems _ = happy_var_3 - ; catchStmts = rev happy_var_4 + ( do { let { tryItems = mkBlockItems happy_var_3 + ; catchStmts = rev happy_var_4 } ; when (null catchStmts) $ throw $ ParserException (happy_var_1 <--> happy_var_3) $ @@ -8948,7 +8944,7 @@ case happyOut52 happy_x_4 of { happy_var_4 -> case happyOut142 happy_x_6 of { happy_var_6 -> happyIn185 - (let Block items _ = happy_var_6 + (let items = mkBlockItems happy_var_6 in ObjCSynchronized happy_var_4 items (happy_var_1 `srcspan` happy_var_6) ) `HappyStk` happyRest}}} @@ -8960,7 +8956,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut142 happy_x_3 of { happy_var_3 -> happyIn185 - (let Block items _ = happy_var_3 + (let items = mkBlockItems happy_var_3 in ObjCAutoreleasepool items (happy_var_1 `srcspan` happy_var_3) )}} @@ -8984,7 +8980,7 @@ case happyOut125 happy_x_5 of { happy_var_5 -> case happyOut142 happy_x_7 of { happy_var_7 -> happyIn186 - (let Block items _ = happy_var_7 + (let items = mkBlockItems happy_var_7 in rcons (ObjCCatch (Just happy_var_5) items (happy_var_2 `srcspan` happy_var_7)) happy_var_1 ) `HappyStk` happyRest}}}} @@ -9002,7 +8998,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut142 happy_x_7 of { happy_var_7 -> happyIn186 - (let Block items _ = happy_var_7 + (let items = mkBlockItems happy_var_7 in rcons (ObjCCatch Nothing items (happy_var_2 `srcspan` happy_var_7)) happy_var_1 ) `HappyStk` happyRest}}} @@ -10528,9 +10524,9 @@ = case happyOut209 happy_x_1 of { happy_var_1 -> case happyOut142 happy_x_3 of { happy_var_3 -> happyIn224 - (let Block stmts loc = happy_var_3 + (let stmts = mkBlockItems happy_var_3 in - ObjCMethDef happy_var_1 stmts (happy_var_1 `srcspan` loc) + ObjCMethDef happy_var_1 stmts (happy_var_1 `srcspan` happy_var_3) )}} happyReduce_917 = happySpecReduce_2 195# happyReduction_917 @@ -10539,9 +10535,9 @@ = case happyOut209 happy_x_1 of { happy_var_1 -> case happyOut142 happy_x_2 of { happy_var_2 -> happyIn224 - (let Block stmts loc = happy_var_2 + (let stmts = mkBlockItems happy_var_2 in - ObjCMethDef happy_var_1 stmts (happy_var_1 `srcspan` loc) + ObjCMethDef happy_var_1 stmts (happy_var_1 `srcspan` happy_var_2) )}} happyReduce_918 = happySpecReduce_1 195# happyReduction_918 @@ -10582,7 +10578,7 @@ case happyOut227 happy_x_2 of { happy_var_2 -> case happyOut142 happy_x_3 of { happy_var_3 -> ( do { assertCudaEnabled (happy_var_1 <--> happy_var_3) "To use lambda-expressions, enable support for CUDA" - ; let Block items _ = happy_var_3 + ; let items = mkBlockItems happy_var_3 ; return $ Lambda happy_var_1 happy_var_2 items (happy_var_1 `srcspan` happy_var_3) })}}} ) (\r -> happyReturn (happyIn226 r)) @@ -11685,6 +11681,14 @@ unless cuda_enabled $ throw $ ParserException loc $ text errMsg +mkBlock :: [BlockItem] -> SrcLoc -> Stm +mkBlock [BlockStm stm] _ = stm +mkBlock items sloc = Block items sloc + +mkBlockItems :: Stm -> [BlockItem] +mkBlockItems (Block items _) = items +mkBlockItems stm = [BlockStm stm] + mkCommentStm :: L T.Token -> Stm -> Stm mkCommentStm tok stm = Comment (getCOMMENT tok) stm (srclocOf tok) @@ -11728,8 +11732,9 @@ locOf (RApp xs ys) = locOf xs `mappend` locOf ys {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} {-# LINE 1 "" #-} -{-# LINE 10 "" #-} +{-# LINE 11 "" #-} # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4 @@ -11775,7 +11780,26 @@ -{-# LINE 10 "" #-} +{-# LINE 11 "" #-} +{-# LINE 1 "/home/mainland/software/haskell-platform-7.10.3/build/ghc-bindist/local/lib/ghc-7.10.3/include/ghcversion.h" #-} + + + + + + + + + + + + + + + + + +{-# LINE 11 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp 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.11.5 +version: 0.11.5.1 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE @@ -13,7 +13,7 @@ homepage: http://www.drexel.edu/~mainland/ category: Language synopsis: C/CUDA/OpenCL/Objective-C quasiquoting library. -tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.3 +tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.3, GHC==7.10.3 description: This package provides a general parser for the C language, including most GCC @@ -24,8 +24,6 @@ extra-source-files: Language/C/Syntax-instances.hs - tests/unit/Objc.hs - tests/unit/MainCPP.hs flag full-haskell-antiquotes description: Support full Haskell expressions/patterns in antiquotes. This @@ -95,6 +93,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests/unit main-is: Main.hs + other-modules: + CUDA + Objc + MainCPP + default-language: Haskell98 build-depends: diff --git a/tests/unit/CUDA.hs b/tests/unit/CUDA.hs new file mode 100644 --- /dev/null +++ b/tests/unit/CUDA.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuasiQuotes #-} + +module CUDA (cudaTests) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit (Assertion, (@?=)) + +import Language.C.Quote.CUDA +import Language.C.Syntax +import Data.Loc (noLoc) + +mkDeclarator params mutability = LambdaDeclarator (Params params False noLoc) mutability Nothing noLoc + +mkIntroducer :: [CaptureListEntry] -> LambdaIntroducer +mkIntroducer mode = (LambdaIntroducer mode noLoc) + +emptyLambda = lambdaByCapture [] +lambdaByCapture captureMode = Lambda (mkIntroducer captureMode) Nothing [] noLoc +lambdaByCaptureBody captureMode statements = Lambda (mkIntroducer captureMode) Nothing statements noLoc +lambdaByCaptureParams captureMode params = Lambda (mkIntroducer captureMode) (Just $ mkDeclarator params False) [] noLoc + +lambdaByParams params = Lambda (mkIntroducer []) (Just $ mkDeclarator params False) [] noLoc +mutableLambdaByParams params = Lambda (mkIntroducer []) (Just $ mkDeclarator params True) [] noLoc + +cudaTests :: Test +cudaTests = testGroup "CUDA" + $ map (testCase "lambda-expressions parsing") lambdas + where + lambdas :: [Assertion] + lambdas = [ [cexp|[=] {}|] @?= lambdaByCapture [DefaultByValue] + , [cexp|[&] {}|] @?= lambdaByCapture[DefaultByReference] + , [cexp|[] {}|] @?= lambdaByCapture [] + , [cexp|[] {}|] @?= emptyLambda + , [cexp|[] () {}|] @?= lambdaByParams [] + , [cexp|[] (int i) {}|] @?= lambdaByParams [param_int_i] + , [cexp|[] (int i, double j) {}|] @?= lambdaByParams [param_int_i, param_double_h] + , [cexp|[] ($param:param_int_i) {}|] @?= lambdaByParams [param_int_i] + , [cexp|[] (int i) mutable {}|] @?= mutableLambdaByParams [param_int_i] + , [cexp|[&] (int i) {}|] @?= lambdaByCaptureParams [DefaultByReference] [param_int_i] + , [cexp|[&] { $item:item_return_7 } |] @?= lambdaCapturingByRefAndReturning7 + , [cexp|[&] { return $exp:exp_7; } |] @?= lambdaCapturingByRefAndReturning7 + , [cexp|[]{}()|] @?= FnCall emptyLambda [] noLoc + , [cexp|[](){}()|] @?= FnCall (lambdaByParams []) [] noLoc + ] + + lambdaCapturingByRefAndReturning7 = lambdaByCaptureBody [DefaultByReference] [item_return_7] + exp_7 = [cexp|7|] + item_return_7 = [citem|return 7;|] + param_int_i = [cparam|int i|] + param_double_h = [cparam|double j|]