Enable rebindable fail with overloaded strings
authorShayne Fletcher <shayne.fletcher@digitalasset.com>
Tue, 11 Dec 2018 18:49:48 +0000 (13:49 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 11 Dec 2018 23:19:46 +0000 (18:19 -0500)
Summary: enable rebindable fail with overloaded strings

Reviewers: bgamari, simonpj

Reviewed By: bgamari, simonpj

Subscribers: simonpj, ndmitchell, rwbarton, carter

GHC Trac Issues: #15645

Differential Revision: https://phabricator.haskell.org/D5251

compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/rename/RnExpr.hs
compiler/typecheck/TcExpr.hs
docs/users_guide/glasgow_exts.rst
testsuite/tests/typecheck/should_compile/T15645.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T15645.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index d887a24..a7d12c2 100644 (file)
@@ -118,12 +118,16 @@ noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit noExt (HsString NoSourceText
                           , syn_arg_wraps = []
                           , syn_res_wrap  = WpHole }
 
+-- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers.
+mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p)
+mkSyntaxExpr expr = SyntaxExpr { syn_expr      = expr
+                               , syn_arg_wraps = []
+                               , syn_res_wrap  = WpHole }
+
 -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
 -- renamer), missing its HsWrappers.
 mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar noExt $ noLoc name
-                                 , syn_arg_wraps = []
-                                 , syn_res_wrap  = WpHole }
+mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExt $ noLoc name
   -- don't care about filling in syn_arg_wraps because we're clearly
   -- not past the typechecker
 
index ac04668..eb899cc 100644 (file)
@@ -187,7 +187,8 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
-mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
+mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) =>
+  [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
 mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches))
   where
     matches = mkMatchGroup Generated
index cc69e43..9ee9669 100644 (file)
@@ -63,6 +63,8 @@ import Data.Ord
 import Data.Array
 import qualified Data.List.NonEmpty as NE
 
+import Unique           ( mkVarOccUnique )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -859,23 +861,7 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
 
-        ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
-        ; let getFailFunction
-                -- If the pattern is irrefutable (e.g.: wildcard, tuple,
-                -- ~pat, etc.) we should not need to fail.
-                | isIrrefutableHsPat pat
-                = return (noSyntaxExpr, emptyFVs)
-
-                -- For non-monadic contexts (e.g. guard patterns, list
-                -- comprehensions, etc.) we should not need to fail.
-                -- See Note [Failing pattern matches in Stmts]
-                | not (isMonadFailStmtContext ctxt)
-                = return (noSyntaxExpr, emptyFVs)
-
-                | xMonadFailEnabled = lookupSyntaxName failMName
-                | otherwise         = lookupSyntaxName failMName_preMFP
-
-        ; (fail_op, fvs2) <- getFailFunction
+        ; (fail_op, fvs2) <- monadFailOp pat ctxt
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
@@ -1211,10 +1197,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 
-       ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
-       ; let failFunction | xMonadFailEnabled = failMName
-                          | otherwise         = failMName_preMFP
-       ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+       ; (fail_op, fvs2) <- getMonadFailOp
 
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
@@ -2120,3 +2103,74 @@ badIpBinds :: Outputable a => SDoc -> a -> SDoc
 badIpBinds what binds
   = hang (text "Implicit-parameter bindings illegal in" <+> what)
          2 (ppr binds)
+
+---------
+
+lookupSyntaxMonadFailOpName :: Bool -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupSyntaxMonadFailOpName monadFailEnabled
+  | monadFailEnabled = lookupSyntaxName failMName
+  | otherwise        = lookupSyntaxName failMName_preMFP
+
+monadFailOp :: LPat GhcPs
+            -> HsStmtContext Name
+            -> RnM (SyntaxExpr GhcRn, FreeVars)
+monadFailOp pat ctxt
+  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
+  -- we should not need to fail.
+  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
+
+  -- For non-monadic contexts (e.g. guard patterns, list
+  -- comprehensions, etc.) we should not need to fail.  See Note
+  -- [Failing pattern matches in Stmts]
+  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
+
+  | otherwise = getMonadFailOp
+
+{-
+Note [Monad fail : Rebindable syntax, overloaded strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given the code
+  foo x = do { Just y <- x; return y }
+
+we expect it to desugar as
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail "Pattern match error"
+
+But with RebindableSyntax and OverloadedStrings, we really want
+it to desugar thus:
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail (fromString "Patterm match error")
+
+So, in this case, we synthesize the function
+  \x -> fail (fromString x)
+
+(rather than plain 'fail') for the 'fail' operation. This is done in
+'getMonadFailOp'.
+-}
+getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp
+ = do { xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
+      ; xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings xMonadFailEnabled }
+  where
+    reallyGetMonadFailOp rebindableSyntax overloadedStrings monadFailEnabled
+      | rebindableSyntax && overloadedStrings = do
+        (failExpr, failFvs) <- lookupSyntaxMonadFailOpName monadFailEnabled
+        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
+        let arg_lit = fsLit "arg"
+            arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
+            arg_syn_expr = mkRnSyntaxExpr arg_name
+        let body :: LHsExpr GhcRn =
+              nlHsApp (noLoc $ syn_expr failExpr)
+                      (nlHsApp (noLoc $ syn_expr fromStringExpr)
+                                (noLoc $ syn_expr arg_syn_expr))
+        let failAfterFromStringExpr :: HsExpr GhcRn =
+              unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body
+        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
+              mkSyntaxExpr failAfterFromStringExpr
+        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
+      | otherwise = lookupSyntaxMonadFailOpName monadFailEnabled
index 8afcc8b..3b8d2c9 100644 (file)
@@ -1458,7 +1458,8 @@ tcSyntaxOp :: CtOrigin
            -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
            -> TcM (a, SyntaxExpr GhcTcId)
 -- ^ Typecheck a syntax operator
--- The operator is always a variable at this stage (i.e. renamer output)
+-- The operator is a variable or a lambda at this stage (i.e. renamer
+-- output)
 tcSyntaxOp orig expr arg_tys res_ty
   = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
 
@@ -1470,18 +1471,15 @@ tcSyntaxOpGen :: CtOrigin
               -> SyntaxOpType
               -> ([TcSigmaType] -> TcM a)
               -> TcM (a, SyntaxExpr GhcTcId)
-tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar _ (L _ op) })
-              arg_tys res_ty thing_inside
-  = do { (expr, sigma) <- tcInferId op
+tcSyntaxOpGen orig op arg_tys res_ty thing_inside
+  = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op
        ; (result, expr_wrap, arg_wraps, res_wrap)
            <- tcSynArgA orig sigma arg_tys res_ty $
               thing_inside
-       ; return (result, SyntaxExpr { syn_expr      = mkHsWrap expr_wrap expr
+       ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr
                                     , syn_arg_wraps = arg_wraps
                                     , syn_res_wrap  = res_wrap }) }
 
-tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)
-
 {-
 Note [tcSynArg]
 ~~~~~~~~~~~~~~~
index 402262e..ea93cda 100644 (file)
@@ -1642,9 +1642,12 @@ not the Prelude versions:
 -  An integer literal ``368`` means "``fromInteger (368::Integer)``",
    rather than "``Prelude.fromInteger (368::Integer)``".
 
--  Fractional literals are handed in just the same way, except that the
+-  Fractional literals are handled in just the same way, except that the
    translation is ``fromRational (3.68::Rational)``.
 
+-  String literals are also handled the same way, except that the
+   translation is ``fromString ("368"::String)``.
+
 -  The equality test in an overloaded numeric pattern uses whatever
    ``(==)`` is in scope.
 
diff --git a/testsuite/tests/typecheck/should_compile/T15645.hs b/testsuite/tests/typecheck/should_compile/T15645.hs
new file mode 100644 (file)
index 0000000..d558b51
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+
+module T15645 where
+
+import Prelude hiding (fail)
+
+foo x = do
+    Just y <- x
+    return y
+
+newtype Text = Text String
+
+fail :: Text -> a
+fail (Text x) = error x
+
+fromString :: String -> Text
+fromString = Text
diff --git a/testsuite/tests/typecheck/should_compile/T15645.stderr b/testsuite/tests/typecheck/should_compile/T15645.stderr
new file mode 100644 (file)
index 0000000..566d6bf
--- /dev/null
@@ -0,0 +1,4 @@
+T15645.hs:8:5: warning: [-Wmissing-monadfail-instances (in -Wcompat)]
+    The failable pattern ‘Just y’
+      is used together with -XRebindableSyntax. If this is intentional,
+      compile with -Wno-missing-monadfail-instances.
index bebdc6c..a8e8cfe 100644 (file)
@@ -653,6 +653,7 @@ test('T15473', normal, compile_fail, [''])
 test('T15499', normal, compile, [''])
 test('T15586', normal, compile, [''])
 test('T15368', normal, compile, ['-fdefer-type-errors'])
+test('T15645', normal, compile, ['-Wwarn=missing-monadfail-instances'])
 test('T15778', normal, compile, [''])
 test('T14761c', normal, compile, [''])
 test('T16008', normal, compile, [''])