Add support for LambdaCase

Test/examples/LambdaCase.hs

@@ -4,3 +4,5 @@ module LambdaCase where
 foo = \case
         Nothing -> e1
         Just e2 -> e2
+
+bar = \    case { _ -> True }

Test/failing.txt

@@ -16,4 +16,3 @@ IndentedWhereBlock.hs    Bug - needs fixes to layout parsing
 NegPrimWordLiteral.hs    Primitive word literals cannot be negative.
 RecordPuns.hs            Qualified record puns not yet supported.
 IndentedTopLevelWhere.hs Weird layout bug.
-LambdaCase.hs            Lambda-case expressions not yet supported.

src/Language/Haskell/Exts/Annotated/ExactPrint.hs

@@ -1404,6 +1404,14 @@ instance ExactP Exp where
             exactPC e2
          _ -> errorEP "ExactP: Exp: RightArrHighApp is given wrong number of srcInfoPoints"
 
+    LCase l alts   ->
+        case srcInfoPoints l of
+         a:b:pts -> do
+            printString "\\"
+            printStringAt (pos b) "case"
+            layoutList pts alts
+         _ -> errorEP "ExactP: Exp: LCase is given wrong number of srcInfoPoints"
+
 instance ExactP FieldUpdate where
   exactP fup = case fup of
     FieldUpdate l qn e  -> do

src/Language/Haskell/Exts/Annotated/Fixity.hs

@@ -323,6 +323,7 @@ leafFix fixs e = case e of
     CorePragma l s e          -> liftM (CorePragma l s) (fix e)
     SCCPragma l s e           -> liftM (SCCPragma l s) (fix e)
     GenPragma l s ab cd e     -> liftM (GenPragma l s ab cd) (fix e)
+    LCase l alts              -> liftM (LCase l) $ mapM fix alts
 
     _                         -> return e
   where

src/Language/Haskell/Exts/Annotated/Simplify.hs

@@ -380,6 +380,7 @@ sExp e = case e of
     RightArrApp     _ e1 e2 -> S.RightArrApp (sExp e1) (sExp e2)
     LeftArrHighApp  _ e1 e2 -> S.LeftArrHighApp (sExp e1) (sExp e2)
     RightArrHighApp _ e1 e2 -> S.RightArrHighApp (sExp e1) (sExp e2)
+    LCase _ alts -> S.LCase (map sAlt alts)
 
 
 sXName :: XName l -> S.XName

src/Language/Haskell/Exts/Annotated/Syntax.hs

@@ -764,6 +764,9 @@ data Exp l
     | RightArrApp     l (Exp l) (Exp l)     -- ^ arrow application (from right): /exp/ @>-@ /exp/
     | LeftArrHighApp  l (Exp l) (Exp l)     -- ^ higher-order arrow application (from left): /exp/ @-<<@ /exp/
     | RightArrHighApp l (Exp l) (Exp l)     -- ^ higher-order arrow application (from right): /exp/ @>>-@ /exp/
+
+-- LambdaCase
+    | LCase l [Alt l]                       -- ^ @\case@ /alts/
 #ifdef __GLASGOW_HASKELL__
   deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable)
 #else
@@ -1447,6 +1450,8 @@ instance Functor Exp where
         LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) (fmap f e1) (fmap f e2)
         RightArrHighApp l e1 e2 -> RightArrHighApp (f l) (fmap f e1) (fmap f e2)
 
+        LCase l alts -> LCase (f l) (map (fmap f) alts)
+
 instance Functor XName where
     fmap f (XName l s)  = XName (f l) s
     fmap f (XDomName l sd sn) = XDomName (f l) sd sn
@@ -2018,6 +2023,8 @@ instance Annotated Exp where
         LeftArrHighApp  l e1 e2 -> l
         RightArrHighApp l e1 e2 -> l
 
+        LCase l alts -> l
+
     amap f e = case e of
         Var l qn        -> Var (f l) qn
         IPVar l ipn     -> IPVar (f l) ipn
@@ -2069,6 +2076,8 @@ instance Annotated Exp where
         LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) e1 e2
         RightArrHighApp l e1 e2 -> RightArrHighApp (f l) e1 e2
 
+        LCase l alts -> LCase (f l) alts
+
 
 instance Annotated XName where
     ann (XName l s)  = l

src/Language/Haskell/Exts/Extension.hs

@@ -365,6 +365,8 @@ data KnownExtension =
   -- > import "network" Network.Socket
   | PackageImports
 
+  | LambdaCase
+
   -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in
   -- GHC 7.  Allow a type variable to be instantiated at a
   -- polymorphic type.

src/Language/Haskell/Exts/Fixity.hs

@@ -381,6 +381,7 @@ leafFix fixs e = case e of
     CorePragma s e          -> liftM (CorePragma s) (fix e)
     SCCPragma s e           -> liftM (SCCPragma s) (fix e)
     GenPragma s ab cd e     -> liftM (GenPragma s ab cd) (fix e)
+    LCase alts              -> liftM LCase $ mapM fix alts
 
     _                       -> return e
   where

src/Language/Haskell/Exts/InternalParser.ly

@@ -1198,6 +1198,9 @@ mdo blocks require the RecursiveDo extension enabled, but the lexer handles that
 
 > exp10b :: { PExp L }
 >       : 'case' exp 'of' altslist      { let (als, inf, ss) = $4 in Case (nIS $1 <++> inf <** ($1:$3:ss)) $2 als }
+>       | '\\' 'case' altslist          {% do { checkEnabled LambdaCase ;
+>                                               let { (als, inf, ss) = $3 } ;
+>                                               return (LCase (nIS $1 <++> inf <** ($1:$2:ss)) als) } }
 >       | '-' fexp                      { NegApp (nIS $1 <++> ann $2 <** [$1]) $2 }
 >       | 'do'  stmtlist                { let (sts, inf, ss) = $2 in Do   (nIS $1 <++> inf <** $1:ss) sts }
 >       | 'mdo' stmtlist                { let (sts, inf, ss) = $2 in MDo  (nIS $1 <++> inf <** $1:ss) sts }

src/Language/Haskell/Exts/ParseSyntax.hs

@@ -96,6 +96,9 @@ data PExp l
     | RightArrApp     l (PExp l) (PExp l)   -- ^ e >- e
     | LeftArrHighApp  l (PExp l) (PExp l)   -- ^ e -<< e
     | RightArrHighApp l (PExp l) (PExp l)   -- ^ e >>- e
+
+-- LambdaCase
+    | LCase l [Alt l]                       -- ^ @\case@ /alts/
    deriving (Eq,Show)
 
 data PFieldUpdate l
@@ -170,6 +173,8 @@ instance Annotated PExp where
         LeftArrHighApp  l e1 e2 -> l
         RightArrHighApp l e1 e2 -> l
 
+        LCase l alts -> l
+
     amap f e = case e of
         Var l qn                -> Var   (f l) qn
         IPVar l ipn             -> IPVar (f l) ipn
@@ -232,6 +237,8 @@ instance Annotated PExp where
         LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) e1 e2
         RightArrHighApp l e1 e2 -> RightArrHighApp (f l) e1 e2
 
+        LCase l alts -> LCase (f l) alts
+
 instance Functor PExp where
       fmap f e = case e of
           Var l qn                -> Var   (f l) (fmap f qn)
@@ -295,6 +302,7 @@ instance Functor PExp where
           LeftArrHighApp  l e1 e2 -> LeftArrHighApp  (f l) (fmap f e1) (fmap f e2)
           RightArrHighApp l e1 e2 -> RightArrHighApp (f l) (fmap f e1) (fmap f e2)
 
+          LCase l alts -> LCase (f l) (map (fmap f) alts)
 
 
 instance Functor PFieldUpdate where

src/Language/Haskell/Exts/ParseUtils.hs

@@ -621,6 +621,9 @@ checkExpr e = case e of
     LeftArrHighApp l e1 e2  -> check2Exprs e1 e2 (S.LeftArrHighApp l)
     RightArrHighApp l e1 e2 -> check2Exprs e1 e2 (S.RightArrHighApp l)
 
+    -- LamdaCase
+    LCase l alts -> return $ S.LCase l alts
+
     _             -> fail $ "Parse error in expression: " ++ prettyPrint e
 
 checkAttr :: ParseXAttr L -> P (S.XAttr L)

src/Language/Haskell/Exts/Pretty.hs

@@ -871,6 +871,10 @@ instance Pretty Exp where
         prettyPrec p (LeftArrHighApp l r)  = parensIf (p > 0) $ myFsep $ [pretty l, text "-<<", pretty r]
         prettyPrec p (RightArrHighApp l r) = parensIf (p > 0) $ myFsep $ [pretty l, text ">>-", pretty r]
 
+        -- LamdaCase
+        prettyPrec p (LCase altList) = parensIf (p > 1) $
+                text "\\case" $$$ ppBody caseIndent (map pretty altList)
+
 
 instance Pretty XAttr where
         pretty (XAttr n v) =
@@ -1637,6 +1641,7 @@ instance SrcInfo loc => Pretty (P.PExp loc) where
         pretty (P.ExplTypeArg _ qn t) =
                 myFsep [pretty qn, text "{|", pretty t, text "|}"]
         pretty (P.BangPat _ e) = text "!" <> pretty e
+        pretty (P.LCase _ altList) = text "\\case" $$$ ppBody caseIndent (map pretty altList)
 
 instance SrcInfo loc => Pretty (P.PFieldUpdate loc) where
         pretty (P.FieldUpdate _ name e) =

src/Language/Haskell/Exts/Syntax.hs

@@ -791,6 +791,9 @@ data Exp
     | RightArrApp     Exp Exp   -- ^ arrow application (from right): /exp/ @>-@ /exp/
     | LeftArrHighApp  Exp Exp   -- ^ higher-order arrow application (from left): /exp/ @-<<@ /exp/
     | RightArrHighApp Exp Exp   -- ^ higher-order arrow application (from right): /exp/ @>>-@ /exp/
+
+-- LambdaCase
+    | LCase [Alt] -- ^ @\case@ /alts/
 #ifdef __GLASGOW_HASKELL__
 #if MIN_VERSION_base(4,6,0)
   deriving (Eq,Ord,Show,Typeable,Data,Generic)