[Git][ghc/ghc][wip/expand-do] do not add a fail block for type syn pattern in do block expansion. cf....
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu Apr 27 18:51:54 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
5cfe6f98 by Apoorv Ingle at 2023-04-27T13:50:49-05:00
do not add a fail block for type syn pattern in do block expansion. cf. typecheck/should/run/Typeable1.hs to avoid spurious overlapping warnings
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
- testsuite/tests/rebindable/T18324b.hs
- testsuite/tests/rebindable/pattern-fails.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1107,9 +1107,9 @@ data HsExpansion orig expanded
-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- (ppr orig)
- -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+ -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ -- (ppr orig)
+ = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
{-
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
+import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
@@ -783,9 +784,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
- -- ; tracePm "matchWrapper" (vcat [ppr ctxt
- -- , text "matchPmChecked"
- -- , ppr $ isMatchContextPmChecked dflags origin ctxt])
+ ; tracePm "matchWrapper" (vcat [ ppr ctxt
+ , text "matches group" <+> ppr matches
+ , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
then addHsScrutTmCs (concat scrs) new_vars $
-- See Note [Long-distance information]
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -108,9 +108,8 @@ arrowMatchContextExhaustiveWarningFlag = \ case
-- 'HsMatchContext' (does not matter whether it is the redundancy check or the
-- exhaustiveness check).
isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
-isMatchContextPmChecked _ origin LambdaExpr
- | isGenerated origin
- = True
+isMatchContextPmChecked _ origin LambdaExpr -- It is likely that this is generated by expanding do stmts
+ = isGenerated origin
isMatchContextPmChecked dflags origin kind
| isGenerated origin
= False
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Tc.Types.Evidence
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
+import GHC.Core.ConLike
import GHC.Core.TyCon
-- Create chunkified tuple types for monad comprehensions
import GHC.Core.Make
@@ -327,7 +328,7 @@ tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
(unLoc expand_expr)
-- Do expansion on the fly
; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
- , text "expnd:" <+> ppr expand_expr
+ , text "expanded:" <+> ppr expand_expr
])
; tcExpr expand_do_expr res_ty
}
@@ -1375,10 +1376,13 @@ 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
+ ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable
+ || (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip
then return $ mkHsLam [pat] lexpr
else mk_fail_lexpr pat lexpr fail_op
}
+ where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True
+ isPatSynCon _ = False
-- makes the fail block
-- TODO: check the discussion around MonadFail.fail type signature.
=====================================
testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
=====================================
@@ -16,3 +16,27 @@ doingThing handler = do
Handler1 -> 1
return action
return v
+
+-- doingThing123 :: Handler -> IO Int
+-- doingThing123 handler = (>>=)
+-- (case handler of
+-- Default -> return 0
+-- _other_handler -> do
+-- asdf <- return 1
+-- let action = case handler of
+-- Handler1 -> 1
+-- return action)
+-- (\v -> return v)
+
+
+-- doingThing123 :: Handler -> IO Int
+-- doingThing123 handler = (>>=)
+-- (case handler of
+-- Default -> return 0
+-- _other_handler ->
+-- (>>=)(return 1) (\asdf ->
+-- let action = case handler of
+-- Handler1 -> 1
+-- in
+-- return action))
+-- (\v -> return v)
=====================================
testsuite/tests/rebindable/T18324b.hs
=====================================
@@ -1,15 +1,6 @@
{-# LANGUAGE GADTs, TypeFamilies, TypeFamilyDependencies #-}
-{-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc.
-{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE EmptyCase #-}
-{-# LANGUAGE EmptyDataDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -23,11 +14,11 @@ unLoc (L _ e) = e
data B = B
+type family Anno a = b
type family XRec p a = r | r -> a
type instance XRec (GhcPass p) a = L (Anno a) a
-type family Anno a = b
data GhcPass (pass :: Pass)
data Pass = Rn
@@ -38,14 +29,9 @@ type family IdGhcP (pass :: Pass) where
type GhcRn = GhcPass 'Rn
-data LHsType pass
data ClsInstDecl pass =
- ClsInstDecl
- { -- cid_tyfam_insts :: [LTyFamInstDecl pass]
- -- ,
- cid_datafam_insts :: [LDataFamInstDecl pass]
- }
+ ClsInstDecl { cid_datafam_insts :: LDataFamInstDecl pass }
-- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
@@ -66,16 +52,9 @@ data FamEqn pass rhs
fffggg :: ClsInstDecl GhcRn -> [Int]
fffggg ddd = -- let
- -- data_fams =
do
- [FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn }] <- unLoc <$> cid_datafam_insts ddd
+ FamEqn { feqn_tycon = L _ _
+ , feqn_rhs = _ } {-:: FamEqn GhcRn (HsDataDefn GhcRn)-} <- unLoc $ cid_datafam_insts ddd
[ 0 ]
- -- in
- -- data_fams
- -- ty_fams = do
- -- TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts ddd
- -- [ 0 ]
- -- in data_fams ++ ty_fams
=====================================
testsuite/tests/rebindable/pattern-fails.hs
=====================================
@@ -10,9 +10,6 @@ qqq ts = do { (a:b:as) <- Just ts
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/5cfe6f983533ac824770121a47694e0c47a56727
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cfe6f983533ac824770121a47694e0c47a56727
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/20230427/f17c165b/attachment-0001.html>
More information about the ghc-commits
mailing list