[Git][ghc/ghc][master] isIrrefutableHsPat: look up ConLikes in the HscEnv
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Aug 16 16:47:39 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bdd77b9e by sheaf at 2024-08-16T12:47:11-04:00
isIrrefutableHsPat: look up ConLikes in the HscEnv
At GhcRn stage, in isIrrefutableHsPat we only looked up data constructors
in the RdrEnv, which meant that we lacked fallibility information for
out-of-scope constructors (which can arise from Template Haskell splices).
Instead, we use 'lookupGREInfo', which looks up the information in
the type environment. This was the correct function to call all along,
but was not used in 572fbc44 due to import cycle reasons. The appropriate
functions, 'irrefutableConLike{Rn,Tc}' have been moved to 'GHC.Rename.Env',
which avoids import cycles.
Fixes #25164
- - - - -
10 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- + testsuite/tests/pmcheck/should_compile/T25164.hs
- + testsuite/tests/pmcheck/should_compile/T25164_aux.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -46,7 +46,7 @@ module GHC.Hs.Pat (
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
- isIrrefutableHsPat, irrefutableConLikeRn, irrefutableConLikeTc,
+ isIrrefutableHsPat,
isBoringHsPat,
@@ -76,15 +76,10 @@ import GHC.Types.SourceText
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
import GHC.Builtin.Types
-import GHC.Types.CompleteMatch
-import GHC.Types.TyThing (tyThingGREInfo)
-import GHC.Types.Unique.DSet
import GHC.Types.Var
import GHC.Types.Name.Reader
-import GHC.Types.GREInfo
import GHC.Core.ConLike
import GHC.Core.DataCon
-import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Types.SrcLoc
@@ -696,64 +691,6 @@ isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat)
CoPat _ pat _ -> go pat
ExpansionPat _ pat -> go pat
--- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn'
--- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]).
-irrefutableConLikeRn :: GlobalRdrEnv
- -> CompleteMatches -- ^ in-scope COMPLETE pragmas
- -> Name -- ^ the 'Name' of the 'ConLike'
- -> Bool
-irrefutableConLikeRn rdr_env comps con_nm =
- case mbInfo of
- Just (IAmConLike conInfo) ->
- case conLikeInfo conInfo of
- ConIsData { conLikeDataCons = tc_cons } ->
- length tc_cons == 1
- ConIsPatSyn ->
- in_single_complete_match con_nm comps
- _ -> False
- where
- -- Sorry: it's horrible to manually call 'wiredInNameTyThing_maybe' here,
- -- but import cycles make calling the right function, namely 'lookupGREInfo',
- -- quite difficult from within this module.
- mbInfo = case tyThingGREInfo <$> wiredInNameTyThing_maybe con_nm of
- Nothing -> greInfo <$> lookupGRE_Name rdr_env con_nm
- Just nfo -> Just nfo
-
--- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc'
--- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]),
--- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker,
--- 'DsCompleteMatches' in the desugarer).
-irrefutableConLikeTc :: NamedThing con
- => [CompleteMatchX con]
- -- ^ in-scope COMPLETE pragmas
- -> ConLike
- -> Bool
-irrefutableConLikeTc comps con =
- case con of
- RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1
- PatSynCon {} -> in_single_complete_match con_nm comps
- where
- con_nm = conLikeName con
-
--- | Internal helper function: check whether a 'ConLike' is the single member
--- of a COMPLETE set without a result 'TyCon'.
---
--- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons]
--- in Note [Irrefutability of ConPat].
-in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool
-in_single_complete_match con_nm = go
- where
- go [] = False
- go (comp:comps)
- | Nothing <- cmResultTyCon comp
- -- conservative, as we don't have enough info to compute
- -- 'completeMatchAppliesAtType'
- , let comp_nms = mapUniqDSet getName $ cmConLikes comp
- , comp_nms == mkUniqDSet [con_nm]
- = True
- | otherwise
- = go comps
-
-- | Is the pattern any of combination of:
--
-- - (pat)
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -86,6 +86,7 @@ import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Rename.Env ( irrefutableConLikeTc )
import GHC.Tc.Types.Evidence
import Control.Monad ( unless, zipWithM )
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -41,6 +41,8 @@ module GHC.Rename.Env (
lookupConstructorInfo, lookupConstructorFields,
lookupGREInfo,
+ irrefutableConLikeRn, irrefutableConLikeTc,
+
lookupGreAvailRn,
-- Rebindable Syntax
@@ -92,6 +94,7 @@ import GHC.Types.TyThing ( tyThingGREInfo )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique.FM
+import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -104,6 +107,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Rename.Unbound
import GHC.Rename.Utils
import GHC.Data.Bag
+import GHC.Types.CompleteMatch
import GHC.Types.PkgQual
import GHC.Types.GREInfo
@@ -2007,8 +2011,9 @@ lookupGREInfo hsc_env nm
mod ImportBySystem
mb_ty_thing <- lookupType hsc_env nm
case mb_ty_thing of
- Nothing -> pprPanic "lookupGREInfo" $
- vcat [ text "lookup failed:" <+> ppr nm ]
+ Nothing -> do
+ pprPanic "lookupGREInfo" $
+ vcat [ text "lookup failed:" <+> ppr nm ]
Just ty_thing -> return $ tyThingGREInfo ty_thing
{-
@@ -2392,3 +2397,67 @@ lookupQualifiedDoName ctxt std_name
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupSyntaxName std_name
Just modName -> lookupNameWithQualifier std_name modName
+
+--------------------------------------------------------------------------------
+-- Helper functions for 'isIrrefutableHsPat'.
+--
+-- (Defined here to avoid import cycles.)
+
+-- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn'
+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]).
+irrefutableConLikeRn :: HasDebugCallStack
+ => HscEnv
+ -> GlobalRdrEnv
+ -> CompleteMatches -- ^ in-scope COMPLETE pragmas
+ -> Name -- ^ the 'Name' of the 'ConLike'
+ -> Bool
+irrefutableConLikeRn hsc_env rdr_env comps con_nm
+ | Just gre <- lookupGRE_Name rdr_env con_nm
+ = go $ greInfo gre
+ | otherwise
+ = go $ lookupGREInfo hsc_env con_nm
+ where
+ go ( IAmConLike conInfo ) =
+ case conLikeInfo conInfo of
+ ConIsData { conLikeDataCons = tc_cons } ->
+ length tc_cons == 1
+ ConIsPatSyn ->
+ in_single_complete_match con_nm comps
+ go _ = False
+
+-- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc'
+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]),
+-- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker,
+-- 'DsCompleteMatches' in the desugarer).
+irrefutableConLikeTc :: NamedThing con
+ => [CompleteMatchX con]
+ -- ^ in-scope COMPLETE pragmas
+ -> ConLike
+ -> Bool
+irrefutableConLikeTc comps con =
+ case con of
+ RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1
+ PatSynCon {} -> in_single_complete_match con_nm comps
+ where
+ con_nm = conLikeName con
+
+-- | Internal helper function: check whether a 'ConLike' is the single member
+-- of a COMPLETE set without a result 'TyCon'.
+--
+-- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons]
+-- in Note [Irrefutability of ConPat].
+in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool
+in_single_complete_match con_nm = go
+ where
+ go [] = False
+ go (comp:comps)
+ | Nothing <- cmResultTyCon comp
+ -- conservative, as we don't have enough info to compute
+ -- 'completeMatchAppliesAtType'
+ , let comp_nms = mapUniqDSet getName $ cmConLikes comp
+ , comp_nms == mkUniqDSet [con_nm]
+ = True
+ | otherwise
+ = go comps
+
+--------------------------------------------------------------------------------
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -85,6 +85,7 @@ import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
+import GHC.Driver.Env (HscEnv)
{- Note [Handling overloaded and rebindable constructs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2211,6 +2212,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
return (stmts2, fvs1 `plusFV` fvs2)
stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
+ hscEnv <- getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
@@ -2218,7 +2220,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
let (stmts', fvss) = unzip pairs
let (need_join, tail') =
-- See Note [ApplicativeDo and refutable patterns]
- if any (hasRefutablePattern strict rdrEnv comps) stmts'
+ if any (hasRefutablePattern strict hscEnv rdrEnv comps) stmts'
then (True, tail)
else needJoin monad_names tail Nothing
@@ -2410,13 +2412,14 @@ of a refutable pattern, in order for the types to work out.
-}
hasRefutablePattern :: Bool -- ^ is -XStrict enabled?
+ -> HscEnv
-> GlobalRdrEnv
-> CompleteMatches
-> ApplicativeArg GhcRn -> Bool
-hasRefutablePattern is_strict rdr_env comps arg =
+hasRefutablePattern is_strict hsc_env rdr_env comps arg =
case arg of
ApplicativeArgOne { app_arg_pattern = pat, is_body_stmt = False}
- -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn rdr_env comps) pat)
+ -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn hsc_env rdr_env comps) pat)
_ -> False
isLetStmt :: LStmt (GhcPass a) b -> Bool
@@ -2725,11 +2728,12 @@ monadFailOp :: LPat GhcRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
strict <- xoptM LangExt.Strict
+ hscEnv <- getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-- we should not need to fail.
- if | isIrrefutableHsPat strict (irrefutableConLikeRn rdrEnv comps) pat
+ if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat
-> return (Nothing, emptyFVs)
-- For non-monadic contexts (e.g. guard patterns, list
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Prelude
import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Env ( irrefutableConLikeRn )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
@@ -196,9 +197,10 @@ expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr
mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_failable_expr doFlav pat@(L loc _) expr fail_op =
do { is_strict <- xoptM LangExt.Strict
+ ; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
- ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn rdrEnv comps) pat
+ ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, text "isIrrefutable:" <+> ppr irrf_pat
])
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
+import GHC.Rename.Env ( irrefutableConLikeTc )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -143,7 +143,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
GHC.Types.Cpr
=====================================
testsuite/tests/pmcheck/should_compile/T25164.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25164 where
+
+import T25164_aux ( genDoBlock )
+
+$( genDoBlock )
=====================================
testsuite/tests/pmcheck/should_compile/T25164_aux.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module T25164_aux where
+
+-- base
+import Data.Functor.Identity
+
+-- template-haskell
+import Language.Haskell.TH.Syntax
+
+--------------------------------------------------------------------------------
+
+newtype Value a = Value { getValue :: a }
+
+genDoBlock :: Q [ Dec ]
+genDoBlock = do
+ funNm <- newName "fun"
+ argNm <- newName "arg"
+ let doBlock =
+ DoE Nothing
+ [ BindS
+ ( ConP 'Value [ ] [ VarP argNm ] )
+ ( AppE ( ConE 'Identity ) ( AppE ( ConE 'Value ) ( ConE '() ) ) )
+ , NoBindS $
+ AppE ( VarE 'pure ) ( VarE argNm )
+ ]
+
+ {-
+ fun :: Identity ()
+ fun = do { Value arg <- Identity ( Value () )
+ ; pure arg }
+ -}
+
+ pure $
+ [ SigD funNm ( AppT ( ConT ''Identity ) ( ConT ''() ) )
+ , FunD funNm [ Clause [ ] ( NormalB doBlock ) [ ] ]
+ ]
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -92,6 +92,7 @@ test('T20642', normal, compile, [overlapping_incomplete])
test('T21360', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T21360b', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T23520', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
+test('T25164', [extra_files(['T25164_aux.hs']), req_th], multimod_compile, ['T25164', '-v0'])
# Other tests
test('pmc001', [], compile, [overlapping_incomplete])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bdd77b9ed575d45d3b2cce0abeaf120bb1c5f824
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bdd77b9ed575d45d3b2cce0abeaf120bb1c5f824
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/20240816/cdb3d406/attachment-0001.html>
More information about the ghc-commits
mailing list