[Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 1 20:11:47 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
9201e4ce by Apoorv Ingle at 2023-05-01T15:11:25-05:00
a new check for irrefutable pattern
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/rebindable/T18324b.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -729,8 +729,8 @@ ppr_expr (XExpr x) = case ghcPass @p of
ppr_expr (PopSrcSpan x) = case ghcPass @p of
GhcPs -> panic "ppr_expr Ps HsPopSrcSpan"
GhcRn -> ppr x
- GhcTc -> panic "ppr_expr Tc HsPopSrcSpan"
-
+ GhcTc -> panic "ppr_expr Tc HsPopSrcSpan"
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
@@ -1114,9 +1114,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/Hs/Pat.hs
=====================================
@@ -502,6 +502,7 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
+
isIrrefutableHsPat :: forall p. (OutputableBndrId p)
=> DynFlags -> LPat (GhcPass p) -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,14 +858,15 @@ warnDiscardedDoBindings rhs rhs_ty
warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg arg_ty
- | Just (SrcSpanAnn _ l, f) <- fish_var fun
+ | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun
, is_gen_then f
-- , isNoSrcSpan l
= do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
, text "arg" <+> ppr arg
, text "arg_ty" <+> ppr arg_ty
, text "f" <+> ppr f <+> ppr (is_gen_then f)
- , text "l" <+> ppr (isNoSrcSpan l)])
+ , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc)
+ ])
warnDiscardedDoBindings arg arg_ty
where
-- retrieve the location info and the head of the application
@@ -879,8 +880,8 @@ warnUnusedBindValue fun arg arg_ty
fish_var _ = Nothing
-- is this id a compiler generated (>>) with expanded do
- is_gen_then :: LIdP GhcTc -> Bool
- is_gen_then (L _ f) = f `hasKey` thenMClassOpKey
+ is_gen_then :: Id -> Bool
+ is_gen_then f = f `hasKey` thenMClassOpKey
warnUnusedBindValue _ _ _ = return ()
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -605,6 +605,7 @@ addTickHsExpr (XExpr (HsTick t e)) =
liftM (XExpr . HsTick t) (addTickLHsExprNever e)
addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr e@(PopSrcSpan _) = pprPanic "addTickHsExpr: impossible happen PopSrcSpan" (ppr e)
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -59,7 +59,6 @@ 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
@@ -81,6 +80,7 @@ import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
import GHC.Types.Basic (Origin (..))
+import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( second )
@@ -1237,8 +1237,8 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding x can fail
-- instead of making an internal name, the fail block is just an anonymous match block
--- stmts ~~> stmt' let / = stmts';
--- _ = fail "..";
+-- stmts ~~> stmt' let / pat = stmts';
+-- _ = fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
@@ -1381,19 +1381,19 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
-- generate a fail block even if it is not really needed. This would fail typechecking as
-- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat
mk_failable_lexpr_tcm pat lexpr fail_op =
- do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation)
- PatBindRhs pat $ return id -- whatever
- ; dflags <- getDynFlags
- ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat
- , ppr $ isIrrefutableHsPat dflags tc_pat
- , ppr $ isPatSynCon (unLoc 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
+ do { tc_env <- getGblEnv
+ ; is_strict <- xoptM LangExt.Strict
+ ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat
+ , ppr $ isIrrefutableHsPatRn tc_env is_strict pat
+ ])
+
+ ; if isIrrefutableHsPatRn tc_env is_strict pat
+ -- don't decorate with fail statement if the pattern is irrefutable
+ -- pattern syns always get a fail block while desugaring so skip
then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
else mk_fail_lexpr pat lexpr fail_op
}
- where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True
- isPatSynCon _ = False
+ where
-- makes the fail block
-- TODO: check the discussion around MonadFail.fail type signature.
@@ -1401,9 +1401,9 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \
+ return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \
(noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr
- , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
+ , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
(noLocA $ genHsApp fail_op
(mk_fail_msg_expr dflags (DoExpr Nothing) pat))
]))
@@ -1415,3 +1415,10 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
<+> text "at" <+> ppr (getLocA pat)
mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
+
+{- Note [Desugaring Do with HsExpansion]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand do blocks before typeching it rather than after type checking it
+TODO expand using examples
+
+-}
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat
, tcCheckPat, tcCheckPat_O, tcInferPat
, tcPats
, addDataConStupidTheta
+ , isIrrefutableHsPatRn
)
where
@@ -40,6 +41,7 @@ import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Name.Reader
+import GHC.Types.TypeEnv (lookupTypeEnv)
import GHC.Core.Multiplicity
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Env
@@ -77,6 +79,7 @@ import GHC.Data.List.SetOps ( getNth )
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.List( partition )
+import Data.Maybe (isJust)
{-
************************************************************************
@@ -1619,3 +1622,45 @@ checkGADT conlike ex_tvs arg_tys = \case
where
has_existentials :: Bool
has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
+
+
+isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool
+isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat
+ where
+ goL :: LPat GhcRn -> Bool
+ goL = go . unLoc
+
+ go :: Pat GhcRn -> Bool
+ go (WildPat {}) = True
+ go (VarPat {}) = True
+ go (LazyPat _ p')
+ | is_strict
+ = isIrrefutableHsPatRn tc_env False p'
+ | otherwise = True
+ go (BangPat _ pat) = goL pat
+ go (ParPat _ _ pat _) = goL pat
+ go (AsPat _ _ _ pat) = goL pat
+ go (ViewPat _ _ pat) = goL pat
+ go (SigPat _ pat _) = goL pat
+ go (TuplePat _ pats _) = all goL pats
+ go (SumPat {}) = False
+ -- See Note [Unboxed sum patterns aren't irrefutable]
+ go (ListPat {}) = False
+
+ go (ConPat
+ { pat_con = L _ dcName
+ , pat_args = details }) = case lookupTypeEnv type_env dcName of
+ Just (ATyCon con) ->
+ isJust (tyConSingleDataCon_maybe con)
+ && all goL (hsConPatArgs details)
+ _ -> False -- conservative.
+ go (LitPat {}) = False
+ go (NPat {}) = False
+ go (NPlusKPat {}) = False
+
+ -- We conservatively assume that no TH splices are irrefutable
+ -- since we cannot know until the splice is evaluated.
+ go (SplicePat {}) = False
+
+ go (XPat ext) = case ext of
+ HsPatExpanded _ pat -> go pat
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -725,6 +725,7 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
+exprCtOrigin (PopSrcSpan (L _ e)) = exprCtOrigin e
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -587,7 +587,7 @@ data HsExpr p
| PopSrcSpan (LHsExpr p)
-- Placeholder for identifying generated source locations in GhcRn phase
-- Should not presist post typechecking
- -- Note [Desugaring Do with HsExpansion] TODO
+ -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
-- ---------------------------------------------------------------------
=====================================
testsuite/tests/rebindable/T18324b.hs
=====================================
@@ -14,7 +14,7 @@ unLoc (L _ e) = e
data B = B
-type family Anno a = b
+type family Anno a = b
type family XRec p a = r | r -> a
type instance XRec (GhcPass p) a = L (Anno a) a
@@ -33,17 +33,14 @@ type GhcRn = GhcPass 'Rn
data ClsInstDecl pass =
ClsInstDecl { cid_datafam_insts :: LDataFamInstDecl pass }
-
--- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
type LDataFamInstDecl pass = XRec pass ([FamEqn pass (HsDataDefn pass)])
--- type TyFamDefltDecl = TyFamInstDecl
type family IdP p
type instance IdP (GhcPass p) = IdGhcP p
type LIdP p = XRec p (IdP p)
-data HsDataDefn pass
+data HsDataDefn pass
data FamEqn pass rhs
= FamEqn
@@ -54,7 +51,9 @@ fffggg :: ClsInstDecl GhcRn -> [Int]
fffggg ddd = -- let
do
FamEqn { feqn_tycon = L _ _
- , feqn_rhs = _ } {-:: FamEqn GhcRn (HsDataDefn GhcRn)-} <- unLoc $ cid_datafam_insts ddd
- [ 0 ]
-
-
+ , feqn_rhs = defns } :: FamEqn GhcRn (HsDataDefn GhcRn) <- unLoc $ cid_datafam_insts ddd
+ [ 0 ] ++ dataSubs defns
+ where
+ dataSubs :: HsDataDefn GhcRn
+ -> [Int]
+ dataSubs = undefined
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9201e4ce457cfc82d5c574b81833066b2b7325d5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9201e4ce457cfc82d5c574b81833066b2b7325d5
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/20230501/0645573e/attachment-0001.html>
More information about the ghc-commits
mailing list