Partial support for C++11 lambda-expressions parsing and printing — see

#52.  Lambdas will work only when CUDA extensions are enabled.

Current limitations:
* only [], [&] and [=] work as a lambda introducers
* the returned type cannot be explicitly specified (it will be deduced from return expression)
* obviously lambdas and their parameters syntax are limited to C language (so (const std::string &s) as a parameter won't parse)

Language/C/Parser/Lexer.x

@@ -235,6 +235,8 @@ c :-
  --
  -- CUDA
  --
+ "mutable" { token TCUDAmutable }
+
  "<<<" / { ifExtension cudaExts }
          { token TCUDA3lt }
 

Language/C/Parser/Parser.y

@@ -255,6 +255,7 @@ import qualified Language.C.Syntax as C
  --
  -- CUDA
  --
+ 'mutable'       { L _ T.TCUDAmutable }
  '<<<'           { L _ T.TCUDA3lt }
  '>>>'           { L _ T.TCUDA3gt }
  '__device__'    { L _ T.TCUDAdevice }
@@ -505,6 +506,10 @@ primary_expression :
   | objc_message_expression { $1 }
   | objc_at_expression      { $1 }
 
+  -- CUDA -- C++11 lambda-expression subset
+  | cuda_lambda_expression  { $1 }
+
+
 postfix_expression :: { Exp }
 postfix_expression :
     primary_expression
@@ -769,6 +774,9 @@ primary_expression_nlt :
   | objc_message_expression { $1 }
   | objc_at_expression      { $1 }
 
+  -- CUDA -- C++11 lambda-expression subset
+  | cuda_lambda_expression  { $1 }
+
 postfix_expression_nlt :: { Exp }
 postfix_expression_nlt :
     primary_expression_nlt
@@ -3248,6 +3256,45 @@ objc_compatibility_alias :
  - CUDA
  -
  ------------------------------------------------------------------------------}
+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
+          ; return $ Lambda $1 $2 items ($1 `srcspan` $3)
+          }
+    }
+
+cuda_lambda_declarator :: { Maybe LambdaDeclarator }
+cuda_lambda_declarator :
+      cuda_lambda_param_list cuda_lambda_mutable cuda_lambda_return_type { Just $ LambdaDeclarator $1 $2 $3 ($1 `srcspan` $3) }
+    | {- empty -} { Nothing }
+
+cuda_lambda_param_list :: { Params }
+cuda_lambda_param_list :
+      '(' ')' { Params [] False ($1 `srcspan` $2) }
+    | '(' parameter_type_list ')' { $2 }
+
+cuda_lambda_mutable :: { Bool }
+cuda_lambda_mutable :
+      'mutable'   { True  }
+    | {- Empty -} { False }
+
+cuda_lambda_return_type :: { Maybe Type }
+cuda_lambda_return_type :
+    {- Empty -} { Nothing }
+    -- FIXME: There should be possibility to explicitly state returned type.
+    -- | '->' type_name { Just ($2::Type) }
+
+cuda_lambda_introducer :: { LambdaIntroducer }
+cuda_lambda_introducer :
+    '[' cuda_lambda_capture_items ']' { LambdaIntroducer $2 ($1 `srcspan` $3)}
+
+cuda_lambda_capture_items :: { [CaptureListEntry] }
+cuda_lambda_capture_items :
+      '&' { [DefaultByReference] }
+    | '=' { [DefaultByValue] }
+    | {- empty -}  { [] }
+
 
 execution_configuration :: { ExeConfig }
 execution_configuration :
@@ -3948,6 +3995,12 @@ assertObjCEnabled loc errMsg = do
     unless objc_enabled $
      throw $ ParserException loc $ text errMsg
 
+assertCudaEnabled :: Loc -> String -> P ()
+assertCudaEnabled loc errMsg = do
+ cuda_enabled <- useCUDAExts
+ unless cuda_enabled $
+  throw $ ParserException loc $ text errMsg
+
 mkCommentStm :: L T.Token -> Stm -> Stm
 mkCommentStm tok stm = Comment (getCOMMENT tok) stm (srclocOf tok)
 

Language/C/Parser/Tokens.hs

@@ -183,6 +183,7 @@ data Token = Teof
            | T__restrict
 
            -- CUDA
+           | TCUDAmutable
            | TCUDA3lt
            | TCUDA3gt
            | TCUDAdevice
@@ -498,6 +499,7 @@ tokenStrings = [(Tlparen,     "("),
                 --
                 -- CUDA extensions
                 --
+                (TCUDAmutable,  "mutable"),
                 (TCUDAdevice,   "__device__"),
                 (TCUDAglobal,   "__global__"),
                 (TCUDAhost,     "__host__"),
@@ -621,6 +623,7 @@ keywords = [("auto",       Tauto,      Nothing),
             --
             -- CUDA
             --
+            ("mutable",      TCUDAmutable,  Just [CUDA]),
             ("__device__",   TCUDAdevice,   Just [CUDA]),
             ("__global__",   TCUDAglobal,   Just [CUDA]),
             ("__host__",     TCUDAhost,     Just [CUDA]),

Language/C/Pretty.hs

@@ -16,6 +16,8 @@ module Language.C.Pretty where
 import Data.Char (isAlphaNum,
                   isLower)
 import Data.Loc
+import Data.Maybe (isJust)
+
 import Language.C.Syntax
 import Text.PrettyPrint.Mainland
 
@@ -944,10 +946,29 @@ instance Pretty Exp where
         srcloc loc <>
         text "@selector" <> parens (text sel)
 
+    pprPrec _ (Lambda captureList decl blockItems loc) =
+        srcloc loc <>
+        ppr captureList <>
+        ppr decl <>
+        ppr blockItems
+
     pprPrec _ (AntiArgs v _)  = pprAnti "args"  v
 
     pprPrec _ (AntiExp v _)   = pprAnti "var"  v
 
+instance Pretty LambdaDeclarator where
+    pprPrec _ (LambdaDeclarator params isMutable returnType loc) =
+        parens (ppr params) <>
+        (if isMutable then text "mutable" else empty) <>
+        (if isJust returnType then text "->" <> ppr returnType else empty)
+
+instance Pretty LambdaIntroducer where
+    pprPrec _ (LambdaIntroducer items loc) = pprLoc loc $ brackets $ commasep (map ppr items)
+
+instance Pretty CaptureListEntry where
+    pprPrec _ DefaultByValue = char '='
+    pprPrec _ DefaultByReference = char '&'
+
 instance Pretty ObjCDictElem where
     pprPrec _ (ObjCDictElem l r _)    = ppr l <+> colon <+> ppr r
     pprPrec _ (AntiObjCDictElems v _) = pprAnti "dictelems" v

Language/C/Quote/CUDA.hs

@@ -5,6 +5,24 @@
 --             :  (c) 2013-2015 Drexel University
 -- License     :  BSD-style
 -- Maintainer  :  mainland@drexel.edu
+-- The quasiquoters exposed by this module support the CUDA extensions, including CUDA-specific declaration specifiers and @\<\<\<…>>>@ kernel invocation syntax.
+--
+-- It includees partial support for C++11 lambda expressions syntax.
+--
+-- Support for lambda-expressions has the following limitations:
+--
+--  * the capture list must either be empty or have only the default capture mode specifier;
+--
+--  * the return type cannot be explicitly specified;
+--
+--  * the package supports C language, not C++, therefore lambda parameter list and body must be in valid C syntax.
+--
+-- Examples of lambdas supported by the 'cexp' quasiquoter:
+--
+-- > [] (int i) mutable {}
+--
+-- > [&] { return 7; }
+--
 
 module Language.C.Quote.CUDA (
     ToIdent(..),

Language/C/Syntax-instances.hs

@@ -236,6 +236,11 @@ instance Located Exp where
   locOf (ObjCEncode _ l) = locOf l
   locOf (ObjCProtocol _ l) = locOf l
   locOf (ObjCSelector _ l) = locOf l
+  locOf (Lambda _ _ _ l) = locOf l
+instance Located LambdaIntroducer where
+  locOf (LambdaIntroducer _ l) = locOf l
+instance Located LambdaDeclarator where
+  locOf (LambdaDeclarator _ _ _ l) = locOf l
 instance Located BlockType where
   locOf (BlockVoid l) = locOf l
   locOf (BlockParam _ l) = locOf l
@@ -542,6 +547,12 @@ instance Relocatable Exp where
   reloc l (ObjCEncode x0 _) = (ObjCEncode x0 (fromLoc l))
   reloc l (ObjCProtocol x0 _) = (ObjCProtocol x0 (fromLoc l))
   reloc l (ObjCSelector x0 _) = (ObjCSelector x0 (fromLoc l))
+  reloc l (Lambda x0 x1 x2 _) = (Lambda x0 x1 x2 (fromLoc l))
+instance Relocatable LambdaIntroducer where
+  reloc l (LambdaIntroducer x0 _) = (LambdaIntroducer x0 (fromLoc l))
+instance Relocatable LambdaDeclarator where
+  reloc l (LambdaDeclarator x0 x1 x2 _) =
+    (LambdaDeclarator x0 x1 x2 (fromLoc l))
 instance Relocatable BlockType where
   reloc l (BlockVoid _) = (BlockVoid (fromLoc l))
   reloc l (BlockParam x0 _) = (BlockParam x0 (fromLoc l))

Language/C/Syntax.hs

@@ -362,6 +362,9 @@ data Exp = Var Id !SrcLoc
          | ObjCEncode Type !SrcLoc
          | ObjCProtocol Id !SrcLoc
          | ObjCSelector String !SrcLoc
+
+         -- CUDA: C++11 lambda-expression
+         | Lambda LambdaIntroducer (Maybe LambdaDeclarator) [BlockItem] !SrcLoc
     deriving (Eq, Ord, Show, Data, Typeable)
 
 data BinOp = Add
@@ -516,6 +519,16 @@ data ObjCArg = ObjCArg (Maybe Id) (Maybe Exp) !SrcLoc
  -
  ------------------------------------------------------------------------------}
 
+data LambdaIntroducer = LambdaIntroducer [CaptureListEntry] !SrcLoc
+    deriving (Eq, Ord, Show, Data, Typeable)
+
+data LambdaDeclarator = LambdaDeclarator Params Bool (Maybe Type) !SrcLoc
+    deriving (Eq, Ord, Show, Data, Typeable)
+
+data CaptureListEntry = DefaultByReference
+                      | DefaultByValue
+    deriving (Eq, Ord, Show, Data, Typeable)
+
 data ExeConfig = ExeConfig
     {  exeGridDim    :: Exp
     ,  exeBlockDim   :: Exp

bin/gen-instances.hs

@@ -42,6 +42,8 @@ main = do
     DERIVE(BlockItem)
     DERIVE(Const)
     DERIVE(Exp)
+    DERIVE(LambdaIntroducer)
+    DERIVE(LambdaDeclarator)
     DERIVE(BlockType)
     DERIVE(ExeConfig)
     DERIVE(ObjCIvarDecl)
@@ -86,6 +88,8 @@ main = do
     DERIVE(BlockItem)
     DERIVE(Const)
     DERIVE(Exp)
+    DERIVE(LambdaIntroducer)
+    DERIVE(LambdaDeclarator)
     DERIVE(BlockType)
     DERIVE(ExeConfig)
     DERIVE(ObjCIvarDecl)

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|]

tests/unit/Main.hs

@@ -15,6 +15,7 @@ import qualified Language.C.Parser as P
 import MainCPP
 import Numeric (showHex)
 import Objc (objcTests)
+import CUDA (cudaTests)
 import System.Exit (exitFailure, exitSuccess)
 import Text.PrettyPrint.Mainland
 
@@ -29,6 +30,7 @@ tests = [ constantTests
         , statementCommentTests
         , regressionTests
         , objcTests
+        , cudaTests
         ]
 
 constantTests :: Test