Implemented \case expressions.
authorMikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Sat, 23 Apr 2011 05:06:38 +0000 (12:06 +0700)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 16 Jul 2012 10:09:35 +0000 (11:09 +0100)
13 files changed:
compiler/deSugar/Coverage.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsExpr.lhs
compiler/main/DynFlags.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/rename/RnExpr.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml

index 2a4486e..28d83c9 100644 (file)
@@ -458,6 +458,8 @@ addTickHsExpr e@(HsOverLit _) = return e
 addTickHsExpr e@(HsLit _) = return e
 addTickHsExpr (HsLam matchgroup) =
         liftM HsLam (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase ty mgs) =
+        liftM (HsLamCase ty) (addTickMatchGroup True mgs)
 addTickHsExpr (HsApp e1 e2) =
         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
 addTickHsExpr (OpApp e1 e2 fix e3) =
index 11fa5d5..4795b5f 100644 (file)
@@ -205,6 +205,15 @@ dsExpr (NegApp expr neg_expr)
 dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 
+dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
+  | isEmptyMatchGroup matches  -- A Core 'case' is always non-empty
+  =                            -- So desugar empty HsLamCase to error call
+    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
+  | otherwise
+  = do { arg_var <- newSysLocalDs arg
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
+
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 \end{code}
index 9a1d050..7a60ae4 100644 (file)
@@ -864,6 +864,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 repE (HsLam (MatchGroup [m] _)) = repLambda m
+repE (HsLamCase _ (MatchGroup ms _))
+                   = do { ms' <- mapM repMatchTup ms
+                        ; repLamCase (nonEmptyCoreList ms') }
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 
 repE (OpApp e1 op _ e2) =
@@ -878,9 +881,10 @@ repE (NegApp x _)        = do
 repE (HsPar x)            = repLE x
 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
-                                      ; ms2 <- mapM repMatchTup ms
-                                      ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsCase e (MatchGroup ms _))
+                          = do { arg <- repLE e
+                               ; ms2 <- mapM repMatchTup ms
+                               ; repCaseE arg (nonEmptyCoreList ms2) }
 repE (HsIf _ x y z)         = do
                              a <- repLE x
                              b <- repLE y
@@ -1455,6 +1459,9 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y]
 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 
+repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
@@ -1893,7 +1900,7 @@ templateHaskellNames = [
     clauseName,
     -- Exp
     varEName, conEName, litEName, appEName, infixEName,
-    infixAppName, sectionLName, sectionRName, lamEName,
+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName,
     condEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
@@ -2058,8 +2065,9 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 
 -- data Exp = ...
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
-    sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
-    letEName, caseEName, doEName, compEName :: Name
+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
+    unboxedTupEName, condEName, letEName, caseEName, doEName,
+    compEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -2069,6 +2077,7 @@ infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
 sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
 lamEName        = libFun (fsLit "lamE")        lamEIdKey
+lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
 tupEName        = libFun (fsLit "tupE")        tupEIdKey
 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
 condEName       = libFun (fsLit "condE")       condEIdKey
@@ -2370,8 +2379,8 @@ clauseIdKey         = mkPreludeMiscIdUnique 262
 
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
-    sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
-    condEIdKey,
+    sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
+    unboxedTupEIdKey, condEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
@@ -2384,21 +2393,22 @@ infixAppIdKey     = mkPreludeMiscIdUnique 275
 sectionLIdKey     = mkPreludeMiscIdUnique 276
 sectionRIdKey     = mkPreludeMiscIdUnique 277
 lamEIdKey         = mkPreludeMiscIdUnique 278
-tupEIdKey         = mkPreludeMiscIdUnique 279
-unboxedTupEIdKey  = mkPreludeMiscIdUnique 280
-condEIdKey        = mkPreludeMiscIdUnique 281
-letEIdKey         = mkPreludeMiscIdUnique 282
-caseEIdKey        = mkPreludeMiscIdUnique 283
-doEIdKey          = mkPreludeMiscIdUnique 284
-compEIdKey        = mkPreludeMiscIdUnique 285
-fromEIdKey        = mkPreludeMiscIdUnique 286
-fromThenEIdKey    = mkPreludeMiscIdUnique 287
-fromToEIdKey      = mkPreludeMiscIdUnique 288
-fromThenToEIdKey  = mkPreludeMiscIdUnique 289
-listEIdKey        = mkPreludeMiscIdUnique 290
-sigEIdKey         = mkPreludeMiscIdUnique 291
-recConEIdKey      = mkPreludeMiscIdUnique 292
-recUpdEIdKey      = mkPreludeMiscIdUnique 293
+lamCaseEIdKey     = mkPreludeMiscIdUnique 279
+tupEIdKey         = mkPreludeMiscIdUnique 280
+unboxedTupEIdKey  = mkPreludeMiscIdUnique 281
+condEIdKey        = mkPreludeMiscIdUnique 282
+letEIdKey         = mkPreludeMiscIdUnique 283
+caseEIdKey        = mkPreludeMiscIdUnique 284
+doEIdKey          = mkPreludeMiscIdUnique 285
+compEIdKey        = mkPreludeMiscIdUnique 286
+fromEIdKey        = mkPreludeMiscIdUnique 287
+fromThenEIdKey    = mkPreludeMiscIdUnique 288
+fromToEIdKey      = mkPreludeMiscIdUnique 289
+fromThenToEIdKey  = mkPreludeMiscIdUnique 290
+listEIdKey        = mkPreludeMiscIdUnique 291
+sigEIdKey         = mkPreludeMiscIdUnique 292
+recConEIdKey      = mkPreludeMiscIdUnique 293
+recUpdEIdKey      = mkPreludeMiscIdUnique 294
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
index a5839c2..bf0f956 100644 (file)
@@ -482,6 +482,12 @@ cvtl e = wrapL (cvt e)
     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                            ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
+    cvt (LamCaseE ms)
+      | null ms        = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
+      | otherwise      = do { ms' <- mapM cvtMatch ms
+                            ; return $ HsLamCase placeHolderType
+                                                 (mkMatchGroup ms')
+                            }
     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
                                 -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
index dcfcb9f..4db827a 100644 (file)
@@ -113,6 +113,8 @@ data HsExpr id
 
   | HsLam     (MatchGroup id)           -- Currently always a single match
 
+  | HsLamCase PostTcType (MatchGroup id) -- Lambda-case
+
   | HsApp     (LHsExpr id) (LHsExpr id) -- Application
 
   -- Operator applications:
@@ -448,6 +450,10 @@ ppr_expr (ExplicitTuple exprs boxity)
 ppr_expr (HsLam matches)
   = pprMatches (LambdaExpr :: HsMatchContext id) matches
 
+ppr_expr (HsLamCase _ matches)
+  = sep [ sep [ptext (sLit "\\case {")],
+          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
+
 ppr_expr (HsCase expr matches)
   = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
           nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
index 60b6e82..02d2004 100644 (file)
@@ -485,6 +485,7 @@ data ExtensionFlag
    | Opt_NondecreasingIndentation
    | Opt_RelaxedLayout
    | Opt_TraditionalRecordSyntax
+   | Opt_LambdaCase
    deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'DynFlag's but also a plethora of
@@ -2162,6 +2163,7 @@ xFlags = [
   ( "NondecreasingIndentation",         Opt_NondecreasingIndentation, nop ),
   ( "RelaxedLayout",                    Opt_RelaxedLayout, nop ),
   ( "TraditionalRecordSyntax",          Opt_TraditionalRecordSyntax, nop ),
+  ( "LambdaCase",                       Opt_LambdaCase, nop ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, nop ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec,
     \ turn_on -> if not turn_on
index 114f7f6..03e8958 100644 (file)
@@ -500,6 +500,7 @@ data Token
   | ITdcolon
   | ITequal
   | ITlam
+  | ITlcase
   | ITvbar
   | ITlarrow
   | ITrarrow
@@ -979,23 +980,37 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
 
 varid :: Action
 varid span buf len =
-  fs `seq`
   case lookupUFM reservedWordsFM fs of
-        Just (keyword,0)    -> do
-                maybe_layout keyword
-                return (L span keyword)
-        Just (keyword,exts) -> do
-                b <- extension (\i -> exts .&. i /= 0)
-                if b then do maybe_layout keyword
-                             return (L span keyword)
-                     else return (L span (ITvarid fs))
-        _other -> return (L span (ITvarid fs))
+    Just (ITcase, _) -> do
+      lambdaCase <- extension lambdaCaseEnabled
+      keyword <- if lambdaCase
+                 then do
+                   lastTk <- getLastTk
+                   return $ case lastTk of
+                     Just ITlam -> ITlcase
+                     _          -> ITcase
+                 else
+                  return ITcase
+      maybe_layout keyword
+      return $ L span keyword
+    Just (keyword, 0) -> do
+      maybe_layout keyword
+      return $ L span keyword
+    Just (keyword, exts) -> do
+      extsEnabled <- extension $ \i -> exts .&. i /= 0
+      if extsEnabled
+       then do
+         maybe_layout keyword
+          return $ L span keyword
+        else
+          return $ L span $ ITvarid fs
+    Nothing ->
+      return $ L span $ ITvarid fs
   where
-        fs = lexemeToFastString buf len
+    !fs = lexemeToFastString buf len
 
 conid :: StringBuffer -> Int -> Token
-conid buf len = ITconid fs
-  where fs = lexemeToFastString buf len
+conid buf len = ITconid $! lexemeToFastString buf len
 
 qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
 qvarsym buf len = ITqvarsym $! splitQualName buf len False
@@ -1007,17 +1022,18 @@ varsym, consym :: Action
 varsym = sym ITvarsym
 consym = sym ITconsym
 
-sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
-    -> P (RealLocated Token)
+sym :: (FastString -> Token) -> Action
 sym con span buf len =
   case lookupUFM reservedSymsFM fs of
-        Just (keyword,exts) -> do
-                b <- extension exts
-                if b then return (L span keyword)
-                     else return (L span $! con fs)
-        _other -> return (L span $! con fs)
+    Just (keyword, exts) -> do
+      extsEnabled <- extension exts
+      let !tk | extsEnabled = keyword
+              | otherwise   = con fs
+      return $ L span tk
+    Nothing ->
+      return $ L span $! con fs
   where
-        fs = lexemeToFastString buf len
+    !fs = lexemeToFastString buf len
 
 -- Variations on the integral numeric literal.
 tok_integral :: (Integer -> Token)
@@ -1094,6 +1110,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
     where f ITdo    = pushLexState layout_do
           f ITmdo   = pushLexState layout_do
           f ITof    = pushLexState layout
+          f ITlcase = pushLexState layout
           f ITlet   = pushLexState layout
           f ITwhere = pushLexState layout
           f ITrec   = pushLexState layout
@@ -1522,6 +1539,7 @@ data PState = PState {
         buffer     :: StringBuffer,
         dflags     :: DynFlags,
         messages   :: Messages,
+        last_tk    :: Maybe Token,
         last_loc   :: RealSrcSpan, -- pos of previous token
         last_len   :: !Int,        -- len of previous token
         loc        :: RealSrcLoc,  -- current loc (end of prev token + 1)
@@ -1626,6 +1644,12 @@ setLastToken loc len = P $ \s -> POk s {
   last_len=len
   } ()
 
+setLastTk :: Token -> P ()
+setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
+
+getLastTk :: P (Maybe Token)
+getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
+
 data AlexInput = AI RealSrcLoc StringBuffer
 
 alexInputPrevChar :: AlexInput -> Char
@@ -1841,6 +1865,8 @@ typeLiteralsBit :: Int
 typeLiteralsBit = 28
 explicitNamespacesBit :: Int
 explicitNamespacesBit = 29
+lambdaCaseBit :: Int
+lambdaCaseBit = 30
 
 
 always :: Int -> Bool
@@ -1890,6 +1916,8 @@ typeLiteralsEnabled flags = testBit flags typeLiteralsBit
 
 explicitNamespacesEnabled :: Int -> Bool
 explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
+lambdaCaseEnabled :: Int -> Bool
+lambdaCaseEnabled flags = testBit flags lambdaCaseBit
 
 -- PState for parsing options pragmas
 --
@@ -1906,6 +1934,7 @@ mkPState flags buf loc =
       buffer        = buf,
       dflags        = flags,
       messages      = emptyMessages,
+      last_tk       = Nothing,
       last_loc      = mkRealSrcSpan loc loc,
       last_len      = 0,
       loc           = loc,
@@ -1949,6 +1978,7 @@ mkPState flags buf loc =
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
                .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
                .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
+               .|. lambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
@@ -2276,7 +2306,13 @@ lexToken = do
         let span = mkRealSrcSpan loc1 end
         let bytes = byteDiff buf buf2
         span `seq` setLastToken span bytes
-        t span buf bytes
+        lt <- t span buf bytes
+        case unLoc lt of
+          ITlineComment _  -> return lt
+          ITblockComment _ -> return lt
+          lt' -> do
+            setLastTk lt'
+            return lt
 
 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
 reportLexError loc1 loc2 buf str
index 21f8782..67baa88 100644 (file)
@@ -275,6 +275,7 @@ incorrect.
  '::'           { L _ ITdcolon }
  '='            { L _ ITequal }
  '\\'           { L _ ITlam }
+ 'lcase'        { L _ ITlcase }
  '|'            { L _ ITvbar }
  '<-'           { L _ ITlarrow }
  '->'           { L _ ITrarrow }
@@ -1388,6 +1389,8 @@ exp10 :: { LHsExpr RdrName }
                                                                 (unguardedGRHSs $6)
                                                             ]) }
         | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
+        | '\\' 'lcase' altslist
+            { LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
index d27ef98..372daa9 100644 (file)
@@ -224,6 +224,10 @@ rnExpr (HsLam matches)
   = rnMatchGroup LambdaExpr matches    `thenM` \ (matches', fvMatch) ->
     return (HsLam matches', fvMatch)
 
+rnExpr (HsLamCase arg matches)
+  = rnMatchGroup CaseAlt matches       `thenM` \ (matches', fvs_ms) ->
+    return (HsLamCase arg matches', fvs_ms)
+
 rnExpr (HsCase expr matches)
   = rnLExpr expr                       `thenM` \ (new_expr, e_fvs) ->
     rnMatchGroup CaseAlt matches       `thenM` \ (new_matches, ms_fvs) ->
index f3c238b..ba2ca74 100644 (file)
@@ -201,6 +201,14 @@ tcExpr (HsLam match) res_ty
   = do { (co_fn, match') <- tcMatchLambda match res_ty
        ; return (mkHsWrap co_fn (HsLam match')) }
 
+tcExpr e@(HsLamCase _ matches) res_ty
+  = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
+       ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
+       ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
+  where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
+                  , ptext (sLit "requires")]
+        match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
+
 tcExpr (ExprWithTySig expr sig_ty) res_ty
  = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 
index aa44471..51d6c12 100644 (file)
@@ -557,6 +557,11 @@ zonkExpr env (HsLam matches)
   = zonkMatchGroup env matches `thenM` \ new_matches ->
     returnM (HsLam new_matches)
 
+zonkExpr env (HsLamCase arg matches)
+  = zonkTcTypeToType env arg   `thenM` \ new_arg ->
+    zonkMatchGroup env matches `thenM` \ new_matches ->
+    returnM (HsLamCase new_arg new_matches)
+
 zonkExpr env (HsApp e1 e2)
   = zonkLExpr env e1   `thenM` \ new_e1 ->
     zonkLExpr env e2   `thenM` \ new_e2 ->
index 11e4f8f..544acd8 100644 (file)
             <entry><option>-XNoPackageImports</option></entry>
           </row>
           <row>
+            <entry><option>-XLambdaCase</option></entry>
+            <entry>Enable <link linkend="lambda-case">lambda-case expressions</link>.</entry>
+            <entry>dynamic</entry>
+            <entry><option>-XNoLambdaCase</option></entry>
+          </row>
+          <row>
             <entry><option>-XSafe</option></entry>
             <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry>
             <entry>dynamic</entry>
index df1ff2c..805f53a 100644 (file)
@@ -1669,6 +1669,27 @@ continues to stand for the unboxed singleton tuple data constructor.
 
 </sect2>
 
+<sect2 id="lambda-case">
+<title>Lambda-case</title>
+<para>
+The <option>-XLambdaCase</option> flag enables expressions of the form
+<programlisting>
+  \case { p1 -> e1; ...; pN -> eN }
+</programlisting>
+which is equivalent to
+<programlisting>
+  \freshName -> case freshName of { p1 -> e1; ...; pN -> eN }
+</programlisting>
+Note that <literal>\case</literal> starts a layout, so you can write
+<programlisting>
+  \case
+    p1 -> e1
+    ...
+    pN -> eN
+</programlisting>
+</para>
+</sect2>
+
 <sect2 id="disambiguate-fields">
 <title>Record field disambiguation</title>
 <para>