base: Remove `Monad(fail)` method and reexport `MonadFail(fail)` instead
[ghc.git] / compiler / rename / RnExpr.hs
index 46ac6b8..ffeb078 100644 (file)
@@ -14,6 +14,7 @@ free variables.
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -34,7 +35,7 @@ import RnFixity
 import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
                         , bindLocalNames
                         , mapMaybeFvRn, mapFvRn
-                        , warnUnusedLocalBinds )
+                        , warnUnusedLocalBinds, typeAppErr )
 import RnUnbound        ( reportUnboundName )
 import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
 import RnTypes
@@ -62,6 +63,8 @@ import Data.Ord
 import Data.Array
 import qualified Data.List.NonEmpty as NE
 
+import Unique           ( mkVarOccUnique )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -168,7 +171,9 @@ rnExpr (HsApp x fun arg)
        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
 
 rnExpr (HsAppType x fun arg)
-  = do { (fun',fvFun) <- rnLExpr fun
+  = do { type_app <- xoptM LangExt.TypeApplications
+       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
+       ; (fun',fvFun) <- rnLExpr fun
        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
        ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
 
@@ -858,23 +863,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')
@@ -1210,10 +1199,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
@@ -1412,7 +1398,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
   where
     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
     new_stmt | non_rec   = head ss
-             | otherwise = L (getLoc (head ss)) rec_stmt
+             | otherwise = cL (getLoc (head ss)) rec_stmt
     rec_stmt = empty_rec_stmt { recS_stmts     = ss
                               , recS_later_ids = nameSetElemsStable used_later
                               , recS_rec_ids   = nameSetElemsStable fwds }
@@ -1811,9 +1797,9 @@ parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
 can do with the rest of the statements in the same "do" expression.
 -}
 
-isStrictPattern :: LPat id -> Bool
-isStrictPattern (L _ pat) =
-  case pat of
+isStrictPattern :: LPat (GhcPass p) -> Bool
+isStrictPattern lpat =
+  case unLoc lpat of
     WildPat{}       -> False
     VarPat{}        -> False
     LazyPat{}       -> False
@@ -2119,3 +2105,69 @@ badIpBinds :: Outputable a => SDoc -> a -> SDoc
 badIpBinds what binds
   = hang (text "Implicit-parameter bindings illegal in" <+> what)
          2 (ppr binds)
+
+---------
+
+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 { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      }
+  where
+    reallyGetMonadFailOp rebindableSyntax overloadedStrings
+      | rebindableSyntax && overloadedStrings = do
+        (failExpr, failFvs) <- lookupSyntaxName failMName
+        (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 = lookupSyntaxName failMName