From a48cd2a045695c5f34ed7b00184a8d91c4fcac0e Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Sun, 19 Apr 2020 20:11:37 -0500
Subject: Allow LambdaCase to be used as a command in proc notation

---
 compiler/GHC/Tc/Gen/Arrow.hs | 27 +++++++++++++++++++++------
 1 file changed, 21 insertions(+), 6 deletions(-)

(limited to 'compiler/GHC/Tc/Gen/Arrow.hs')

diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 5d26927ed4..6ac42a76d0 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -151,13 +151,14 @@ tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
 tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
       (scrut', scrut_ty) <- tcInferRho scrut
-      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
+      matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
       return (HsCmdCase x scrut' matches')
-  where
-    match_ctxt = MC { mc_what = CaseAlt,
-                      mc_body = mc_body }
-    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
-                              ; tcCmd env body (stk, res_ty') }
+
+tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty)
+  = addErrCtxt (cmdCtxt in_cmd) $ do
+      (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk
+      matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty)
+      return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches'))
 
 tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'
   = do  { pred' <- tcLExpr pred (mkCheckExpType boolTy)
@@ -330,6 +331,20 @@ tc_cmd _ cmd _
   = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),
                       text "was found where an arrow command was expected"])
 
+-- | Typechecking for case command alternatives. Used for both
+-- 'HsCmdCase' and 'HsCmdLamCase'.
+tcCmdMatches :: CmdEnv
+             -> TcType                           -- ^ type of the scrutinee
+             -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives
+             -> CmdType
+             -> TcM (MatchGroup GhcTcId (LHsCmd GhcTcId))
+tcCmdMatches env scrut_ty matches (stk, res_ty)
+  = tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
+  where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = mc_body }
+    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
+                              ; tcCmd env body (stk, res_ty') }
 
 matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
 matchExpectedCmdArgs 0 ty
-- 
cgit v1.2.1