[Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 1 17:47:55 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
6b457021 by Apoorv Ingle at 2023-05-01T12:47:20-05:00
a new check for irrefutable pattern
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.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
=====================================
@@ -67,6 +67,7 @@ import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Basic
+import GHC.Types.TypeEnv
import GHC.Types.SourceText
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
@@ -502,6 +503,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/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 )
@@ -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))
]))
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b4570211c23fd8ab3b03843886782003203948b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b4570211c23fd8ab3b03843886782003203948b
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/901c81b5/attachment-0001.html>
More information about the ghc-commits
mailing list