rename: Don't require 'fail' in non-monadic contexts
authorBen Gamari <ben@smart-cactus.org>
Thu, 22 Dec 2016 18:55:30 +0000 (13:55 -0500)
committerBen Gamari <ben@smart-cactus.org>
Fri, 23 Dec 2016 20:01:56 +0000 (15:01 -0500)
Fixes #11216.

compiler/hsSyn/HsExpr.hs
compiler/rename/RnExpr.hs
testsuite/tests/rebindable/T11216A.hs [new file with mode: 0644]
testsuite/tests/rebindable/all.T

index d695d8e..1b6ccdc 100644 (file)
@@ -2338,6 +2338,15 @@ isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
 isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
 isMonadCompExpr _                    = False
 
+-- | Should pattern match failure in a 'HsStmtContext' be desugared using
+-- 'MonadFail'?
+isMonadFailStmtContext :: HsStmtContext id -> Bool
+isMonadFailStmtContext MonadComp    = True
+isMonadFailStmtContext DoExpr       = True
+isMonadFailStmtContext MDoExpr      = True
+isMonadFailStmtContext GhciStmtCtxt = True
+isMonadFailStmtContext _            = False
+
 matchSeparator :: HsMatchContext id -> SDoc
 matchSeparator (FunRhs {})  = text "="
 matchSeparator CaseAlt      = text "->"
@@ -2414,6 +2423,9 @@ pprStmtContext (TransStmtCtxt c)
  | opt_PprStyle_Debug = sep [text "transformed branch of", pprAStmtContext c]
  | otherwise          = pprStmtContext c
 
+instance (Outputable id, Outputable (NameOrRdrName id))
+      => Outputable (HsStmtContext id) where
+    ppr = pprStmtContext
 
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id
index 7cafc2b..5427579 100644 (file)
@@ -803,9 +803,16 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
 
         ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
-        ; let failFunction | xMonadFailEnabled = failMName
-                           | otherwise         = failMName_preMFP
-        ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+        ; let getFailFunction
+                -- For non-monadic contexts (e.g. guard patterns, list
+                -- comprehensions, etc.) we should not need to fail
+                | not (isMonadFailStmtContext ctxt)
+                                    = return (err, emptyFVs)
+                | xMonadFailEnabled = lookupSyntaxName failMName
+                | otherwise         = lookupSyntaxName failMName_preMFP
+                where err = pprPanic "rnStmt: fail function forced"
+                                     (text "context:" <+> ppr ctxt)
+        ; (fail_op, fvs2) <- getFailFunction
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
diff --git a/testsuite/tests/rebindable/T11216A.hs b/testsuite/tests/rebindable/T11216A.hs
new file mode 100644 (file)
index 0000000..4bc06f6
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE RebindableSyntax #-}
+
+module Bug where
+
+data Maybe a = Just a | Nothing
+
+foo :: [Maybe a] -> [a]
+foo xs = [ x | Just x <- xs ]
index f1737e9..dd51e2b 100644 (file)
@@ -31,5 +31,6 @@ test('T4851', normal, compile, [''])
 
 test('T5908', normal, compile, [''])
 test('T10112', normal, compile, [''])
-test('T11216', [expect_broken(11216)], compile, [''])
+test('T11216', normal, compile, [''])
+test('T11216A', normal, compile, [''])
 test('T12080', normal, compile, [''])