[Git][ghc/ghc][wip/expand-do] move expand_do_stmts GHC.Tc.Match so that we can type check patterns and...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Wed Mar 22 23:40:08 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
a40ab2dc by Apoorv Ingle at 2023-03-22T18:39:50-05:00
move expand_do_stmts GHC.Tc.Match so that we can type check patterns and determine more accurately if we need to generate a fail block
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- + testsuite/tests/rebindable/T23147.hs
- testsuite/tests/rebindable/all.T
- testsuite/tests/rebindable/pattern-fails.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -418,6 +418,23 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
+
+{- *********************************************************************
+* *
+ Generating code for HsExpanded
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+-- | Build a 'HsExpansion' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- desugared expressions.
+mkExpandedExpr
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+mkExpandedExpr a b = XExpr (HsExpanded a b)
+
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -24,7 +24,7 @@ free variables.
-}
module GHC.Rename.Expr (
- rnLExpr, rnExpr, rnStmts, mkExpandedExpr,
+ rnLExpr, rnExpr, rnStmts,
AnnoBody, UnexpectedStatement(..)
) where
@@ -58,7 +58,6 @@ import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Fixity
import GHC.Types.Id.Make
-import GHC.Types.Basic(Origin(..))
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
@@ -77,7 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import Data.List (unzip4, minimumBy, (\\))
+import Data.List (unzip4, minimumBy)
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
@@ -433,24 +432,8 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
= do { ((stmts1, _), fvs1) <-
rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
(\ _ -> return ((), emptyFVs))
- ; ((pp_stmts, fvs2), is_app_do) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
- ; let orig_do_block = HsDo noExtField do_or_lc (L l pp_stmts)
- ; return $ case do_or_lc of
- DoExpr {} -> (if is_app_do
- -- TODO i don't want to thing about applicative stmt rearrangements yet
- then orig_do_block
- else let expd_do_block = expand_do_stmts do_or_lc pp_stmts
- in mkExpandedExpr orig_do_block expd_do_block
- , fvs1 `plusFV` fvs2 )
- MDoExpr {} -> (if is_app_do
- -- TODO i don't want to thing about applicative stmt rearrangements yet
- then orig_do_block
- else let expd_do_block = expand_do_stmts do_or_lc pp_stmts
- in mkExpandedExpr orig_do_block expd_do_block
- , fvs1 `plusFV` fvs2 )
- _ -> (orig_do_block, fvs1 `plusFV` fvs2)
- -- ListComp -> (orig_do_block, fvs1 `plusFV` fvs2)
- -- GhciStmtCtxt -> (orig_do_block, fvs1 `plusFV` fvs2)
+ ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
+ ; return (HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2)
}
-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
rnExpr (ExplicitList _ exps)
@@ -1074,7 +1057,7 @@ rnStmts ctxt rnBody stmts thing_inside
postProcessStmtsForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
- -> RnM (([ExprLStmt GhcRn], FreeVars), Bool) -- True <=> applicative do statement
+ -> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo ctxt stmts
= do {
-- rearrange the statements using ApplicativeStmt if
@@ -1089,9 +1072,9 @@ postProcessStmtsForApplicativeDo ctxt stmts
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
; ado_stmts_and_fvs <- rearrangeForApplicativeDo ctxt stmts
- ; return (ado_stmts_and_fvs, True) }
+ ; return ado_stmts_and_fvs }
else do { do_stmts_and_fvs <- noPostProcessStmts (HsDoStmt ctxt) stmts
- ; return (do_stmts_and_fvs, False) } }
+ ; return do_stmts_and_fvs } }
-- | strip the FreeVars annotations from statements
noPostProcessStmts
@@ -2713,158 +2696,6 @@ getMonadFailOp ctxt
* *
********************************************************************* -}
--- | Build a 'HsExpansion' out of an extension constructor,
--- and the two components of the expansion: original and
--- desugared expressions.
-mkExpandedExpr
- :: HsExpr GhcRn -- ^ source expression
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (HsExpanded a b)
-
-
-
--- | Expand the Do statments so that it works fine with Quicklook
--- See Note[Rebindable Do Expanding Statements]
--- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is displayed on the expanded expr and not on the unexpanded expr
-expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> HsExpr GhcRn
-
-expand_do_stmts do_flavour [L _ (LastStmt _ body _ NoSyntaxExprRn)]
- -- if it is a last statement of a list comprehension, we need to explicitly return it -- See Note [TODO]
- -- genHsApp (genHsVar returnMName) body
- | ListComp <- do_flavour
- = genHsApp (genHsVar returnMName) body
- | MonadComp <- do_flavour
- = unLoc body -- genHsApp (genHsVar returnMName) body
- | otherwise
- -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = unLoc body
-
-expand_do_stmts _ [L _ (LastStmt _ body _ (SyntaxExprRn ret))]
---
--- ------------------------------------------------
--- return e ~~> return e
--- definitely works T18324.hs
- = unLoc $ mkHsApp (noLocA ret) body
-
-expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn x e)): lstmts)
- | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
- , Just (SyntaxExprRn fail_op) <- xbsrn_failOp xbsrn =
--- the pattern binding x can fail
--- stmts ~~> stmt' let f x = stmts'; f _ = fail ".."
--- -------------------------------------------------------
--- x <- e ; stmts ~~> (Prelude.>>=) e f
-
- foldl genHsApp bind_op -- (>>=)
- [ e
- , noLocA $ failable_expr x (expand_do_stmts do_or_lc lstmts) fail_op
- ]
- | SyntaxExprRn bop <- xbsrn_bindOp xbsrn
- , Nothing <- xbsrn_failOp xbsrn = -- irrefutable pattern so no failure
--- stmts ~~> stmt'
--- ------------------------------------------------
--- x <- e ; stmts ~~> (Prelude.>>=) e (\ x -> stmts')
- foldl genHsApp bop -- (>>=)
- [ e
- , mkHsLam [x] (noLocA $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
- ]
-
- | otherwise = -- just use the polymorhpic bindop. TODO: Necessary?
- genHsApps bindMName -- (Prelude.>>=)
- [ e
- , mkHsLam [x] (noLocA $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
- ]
-
- where
- failable_expr :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
- failable_expr pat expr fail_op = HsLam noExtField $
- mkMatchGroup Generated
- (noLocA [ mkHsCaseAlt pat (noLocA expr)
- , mkHsCaseAlt nlWildPatName
- (noLocA $ genHsApp fail_op
- (nlHsLit $ mkHsString "fail pattern")) ])
-
-expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
--- stmts ~~> stmts'
--- ------------------------------------------------
--- let x = e ; stmts ~~> let x = e in stmts'
- HsLet NoExtField noHsTok bnds noHsTok
- $ noLocA (expand_do_stmts do_or_lc lstmts)
-
-
-expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
--- stmts ~~> stmts'
--- ----------------------------------------------
--- e ; stmts ~~> (Prelude.>>) e stmt'
- unLoc $ nlHsApp (nlHsApp (noLocA f) -- (>>) See Note [BodyStmt]
- e)
- $ (noLocA $ expand_do_stmts do_or_lc lstmts)
-
-expand_do_stmts do_or_lc ((L l (RecStmt { recS_stmts = rec_stmts
- , recS_later_ids = later_ids -- forward referenced local ids
- , recS_rec_ids = local_ids -- ids referenced outside of the rec block
- , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
- , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
- -- use it explicitly
- -- at the end of expanded rec block
- }))
- : lstmts) =
--- See Note [Typing a RecStmt]
--- stmts ~~> stmts'
--- -------------------------------------------------------------------------------------------
--- rec { later_ids, local_ids, rec_block } ; stmts
--- ~~> (Prelude.>>=) (mfix (\[ local_ids ++ later_ids ]
--- -> do { rec_stmts
--- ; return (later_ids, local_ids) } ))
--- (\ [ local_ids ++ later_ids ] -> stmts')
-
- genHsApps bindMName -- (Prelude.>>=)
- [ (noLocA mfix_fun) `mkHsApp` mfix_expr -- mfix (do block)
- , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x -> stmts')
- (L l $ expand_do_stmts do_or_lc lstmts)
- ]
- where
- local_only_ids = local_ids \\ later_ids -- get unique local rec ids; local rec ids and later ids overlap
- all_ids = local_only_ids ++ later_ids -- put local ids before return ids
-
- return_stmt :: ExprLStmt GhcRn
- return_stmt = noLocA $ LastStmt noExtField
- (mkHsApp (noLocA return_fun)
- $ mkBigLHsTup (map nlHsVar all_ids) noExtField)
- Nothing
- (SyntaxExprRn return_fun)
- do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
- do_stmts = noLocA $ (unLoc rec_stmts) ++ [return_stmt]
- do_block :: LHsExpr GhcRn
- do_block = noLocA $ HsDo noExtField (DoExpr Nothing) $ do_stmts
- mfix_expr :: LHsExpr GhcRn
- mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
-
-expand_do_stmts _ (stmt@(L _ (RecStmt {})):_) =
- pprPanic "expand_do_stmts: impossible happened RecStmt" $ ppr stmt
-
-
-expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
- pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
-
-expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
--- See See Note [Monad Comprehensions]
--- Parallel statements only appear in
--- stmts ~~> stmts'
--- -------------------------------------------------------------------------------------------
--- ; stmts
--- ~~> (Prelude.>>=) (mfix (\[ local_ids ++ later_ids ]
--- -> do { rec_stmts
--- ; return (later_ids, local_ids) } ))
--- (\ [ local_ids ++ later_ids ] -> stmts')
- pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
-
-expand_do_stmts _ (stmt@(L _ (ApplicativeStmt {})):_) =
--- See Note [Applicative BodyStmt]
-
- pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" $ ppr stmt
-
-expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -49,7 +49,6 @@ import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
-import GHC.Rename.Expr ( mkExpandedExpr )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -42,7 +42,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr )
-import GHC.Rename.Utils ( bindLocalNames )
+import GHC.Rename.Utils ( bindLocalNames, genHsApp, genHsApps, genHsVar )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
@@ -66,6 +66,7 @@ import GHC.Hs
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
+import GHC.Builtin.Names (bindMName, returnMName)
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -76,11 +77,12 @@ import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
+import GHC.Types.Basic (Origin (..))
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
-
+import Data.List ((\\))
{-
************************************************************************
* *
@@ -316,14 +318,29 @@ tcDoStmts ListComp (L l stmts) res_ty
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty doExpr (L l stmts')) }
+ = do { -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+ -- ; res_ty <- readExpType res_ty
+ -- ; return (HsDo res_ty doExpr (L l stmts'))
+ expand_expr <- expand_do_stmts doExpr stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts" (text "tcExpr:" <+> ppr expand_do_expr)
+ ; tcExpr expand_do_expr res_ty
+ }
tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty mDoExpr (L l stmts')) }
+ = do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
+ -- ; res_ty <- readExpType res_ty
+ -- ; return (HsDo res_ty mDoExpr (L l stmts'))
+ expand_expr <- expand_do_stmts mDoExpr stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts" (text "tcExpr:" <+> ppr expand_do_expr)
+ ; tcExpr expand_do_expr res_ty
+
+ }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
@@ -857,7 +874,7 @@ tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
= do { body' <- tcMonoExprNC body res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
-
+-- ANI TODO: This is really needed?
tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
@@ -896,7 +913,7 @@ tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
\ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
-
+-- ANI TODO: can we get rid of this?
tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
= do { -- Deal with rebindable syntax;
-- (>>) :: rhs_ty -> new_res_ty -> res_ty
@@ -909,7 +926,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty
; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
-
+-- ANI TODO: Is this really needed?
tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names, recS_ret_fn = ret_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
@@ -1172,3 +1189,168 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
args_in_match (L _ (Match { m_pats = pats })) = length pats
+
+{-
+************************************************************************
+* *
+\subsection{HsExpansion for Do Statements}
+* *
+************************************************************************
+-}
+-- | Expand the Do statments so that it works fine with Quicklook
+-- See Note[Rebindable Do and Expanding Statements]
+-- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is displayed on the expanded expr and not on the unexpanded expr
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+
+expand_do_stmts do_flavour [L _ (LastStmt _ body _ ret_expr)]
+ -- last statement of a list comprehension, needs to explicitly return it
+ -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
+ -- TODO: i don't think we need this if we never call from a ListComp
+ | ListComp <- do_flavour
+ = return $ noLocA (genHsApp (genHsVar returnMName) body)
+ | NoSyntaxExprRn <- ret_expr
+ -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
+ = return body
+ | SyntaxExprRn ret <- ret_expr
+ --
+ -- ------------------------------------------------
+ -- return e ~~> return e
+ -- to make T18324 work
+ = return $ mkHsApp (noLocA ret) body
+
+
+expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
+ | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
+ , Just (SyntaxExprRn fail_op) <- xbsrn_failOp xbsrn =
+-- the pattern binding x can fail
+-- stmts ~~> stmt' let f pat = stmts'; f _ = fail ".."
+-- -------------------------------------------------------
+-- pat <- e ; stmts ~~> (Prelude.>>=) e f
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
+ return $ noLocA (foldl genHsApp bind_op -- (>>=)
+ [ e
+ , expr
+ ])
+
+ | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
+ , Nothing <- xbsrn_failOp xbsrn = -- irrefutable pattern so no failure
+-- stmts ~~> stmt'
+-- ------------------------------------------------
+-- x <- e ; stmts ~~> (Prelude.>>=) e (\ x -> stmts')
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (foldl genHsApp bind_op -- (>>=)
+ [ e
+ , mkHsLam [pat] expand_stmts -- (\ x -> stmts')
+ ])
+
+ | otherwise = -- just use the polymorhpic bindop. TODO: Necessary?
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (genHsApps bindMName -- (Prelude.>>=)
+ [ e
+ , mkHsLam [pat] expand_stmts -- (\ x -> stmts')
+ ])
+
+ where
+ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ -- checks the pattern pat and decides if we need to plug in the fail block
+ -- Type checking the pattern is necessary to decide if we need to generate the fail block
+ -- Renamer cannot always determine if a fail block is necessary, and its conservative behaviour would
+ -- generate a fail block even if it is not really needed. cf. GHC.Hs.isIrrefutableHsPat
+ -- Only Tuples are considered irrefutable in the renamer, while newtypes and TyCons with only one datacon
+ -- is not
+ mk_failable_lexpr_tcm pat lexpr fail_op =
+ do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation)
+ PatBindRhs pat $ return id -- whatever
+ ; dflags <- getDynFlags
+ ; if isIrrefutableHsPat dflags tc_pat
+ then return $ mkHsLam [pat] lexpr
+ else return $ mk_fail_lexpr pat lexpr fail_op
+ }
+ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
+ -- makes the fail block
+ -- TODO: check the discussion around MonadFail.fail type signature.
+ -- Should we really say `mkHsString "fail pattern"`? if yes, maybe a better error message would help
+ mk_fail_lexpr pat lexpr fail_op =
+ noLocA (HsLam noExtField $ mkMatchGroup Generated -- let
+ (noLocA [ mkHsCaseAlt pat lexpr -- f pat = expr
+ , mkHsCaseAlt nlWildPatName -- f _ = fail "fail pattern"
+ (noLocA $ genHsApp fail_op
+ (nlHsLit $ mkHsString "fail pattern")) ]))
+
+expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
+-- stmts ~~> stmts'
+-- ------------------------------------------------
+-- let x = e ; stmts ~~> let x = e in stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (HsLet noExtField noHsTok bnds noHsTok (expand_stmts))
+
+
+expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+-- See Note [BodyStmt]
+-- stmts ~~> stmts'
+-- ----------------------------------------------
+-- e ; stmts ~~> (>>) e stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ mkHsApps (noLocA f) -- (>>)
+ [ e -- e
+ , expand_stmts ] -- stmts'
+
+expand_do_stmts do_or_lc ((L _ (RecStmt { recS_stmts = rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ -- use it explicitly
+ -- at the end of expanded rec block
+ }))
+ : lstmts) =
+-- See Note [Typing a RecStmt]
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------------------------
+-- rec { later_ids, local_ids, rec_block } ; stmts
+-- ~~> (>>=) (mfix (\[ local_only_ids ++ later_ids ]
+-- -> do { rec_stmts
+-- ; return (local_only_ids ++ later_ids) } ))
+-- (\ [ local_only_ids ++ later_ids ] -> stmts')
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (genHsApps bindMName -- (Prelude.>>=)
+ [ (noLocA mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ expand_stmts -- stmts')
+ ])
+ where
+ local_only_ids = local_ids \\ later_ids -- get unique local rec ids; local rec ids and later ids overlap
+ all_ids = local_only_ids ++ later_ids -- put local ids before return ids
+
+ return_stmt :: ExprLStmt GhcRn
+ return_stmt = noLocA $ LastStmt noExtField
+ (mkHsApp (noLocA return_fun)
+ $ mkBigLHsTup (map nlHsVar all_ids) noExtField)
+ Nothing
+ (SyntaxExprRn return_fun)
+ do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
+ do_stmts = noLocA $ (unLoc rec_stmts) ++ [return_stmt]
+ do_block :: LHsExpr GhcRn
+ do_block = noLocA $ HsDo noExtField (DoExpr Nothing) $ do_stmts
+ mfix_expr :: LHsExpr GhcRn
+ mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
+
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt _ appargs (Just join))):_) =
+-- See Note [Applicative BodyStmt]
+ pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt _ appargs Nothing)):_) =
+-- See Note [Applicative BodyStmt]
+ pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+-- See See Note [Monad Comprehensions]
+
+ pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
+
+
+expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -104,7 +104,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
-----------------
tcPats :: HsMatchContext GhcTc
- -> [LPat GhcRn] -- ^ atterns
+ -> [LPat GhcRn] -- ^ patterns
-> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns
-> TcM a -- ^ checker for the body
-> TcM ([LPat GhcTc], a)
=====================================
testsuite/tests/rebindable/T23147.hs
=====================================
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE GADTs #-}
+
+module T23147 where
+
+import qualified Control.Monad as M
+import Prelude hiding (return, (>>=))
+
+type Exis f = (forall r. (forall t. f t -> r) -> r)
+
+data Indexed t where
+ Indexed :: Indexed Int
+
+(>>=) :: Monad m => m (Exis f) -> (forall t. f t -> m (Exis g)) -> m (Exis g)
+x >>= f = x M.>>= (\x' -> x' f)
+
+return :: Monad m => Exis f -> m (Exis f)
+return = M.return
+
+test :: (Monad m) => Exis Indexed -> m (Exis Indexed)
+test x =
+ T23147.do
+ (reified :: Indexed t) <- return x
+ return (\g -> g reified)
=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -42,5 +42,7 @@ test('T14670', expect_broken(14670), compile, [''])
test('T19167', normal, compile, [''])
test('T19918', normal, compile_and_run, [''])
test('T20126', normal, compile_fail, [''])
-test('T18324', normal, compile_and_run, [''])
-test('pattern-fails', normal, compile_and_run, [''])
+# Tests for desugaring do before typechecking
+test('T18324', normal, compile, [''])
+test('T23147', normal, compile, [''])
+test('pattern-fails', normal, compile, [''])
=====================================
testsuite/tests/rebindable/pattern-fails.hs
=====================================
@@ -1,9 +1,18 @@
-module Main where
+module PF where
-main :: IO ()
-main = putStrLn . show $ qqq ['c']
+-- main :: IO ()
+-- main = putStrLn . show $ qqq ['c']
qqq :: [a] -> Maybe (a, [a])
qqq ts = do { (a:b:as) <- Just ts
; return (a, as) }
+
+newtype ST a b = ST (a, b)
+
+emptyST :: Maybe (ST Int Int)
+emptyST = Just $ ST (0, 0)
+
+ppp :: Maybe (ST Int Int) -> Maybe (ST Int Int)
+ppp st = do { ST (x, y) <- st
+ ; return $ ST (x+1, y+1)}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a40ab2dc5b88d37b9b2deee5e657c83a03d6d2c8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a40ab2dc5b88d37b9b2deee5e657c83a03d6d2c8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230322/546ac0b0/attachment-0001.html>
More information about the ghc-commits
mailing list