Commit 8a4edd15 authored by Shayne Fletcher's avatar Shayne Fletcher 🥝 Committed by Ben Gamari

Enable rebindable fail with overloaded strings

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
parent c98e25a4
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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]
~~~~~~~~~~~~~~~
......
......@@ -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.
......
{-# 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
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.
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment