[Git][ghc/ghc][wip/T25257] 2 commits: HsExpr: Inline `HsWrap` into `WrapExpr`
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Sep 17 07:19:16 UTC 2024
Sebastian Graf pushed to branch wip/T25257 at Glasgow Haskell Compiler / GHC
Commits:
0948e83b by Sebastian Graf at 2024-09-17T09:19:05+02:00
HsExpr: Inline `HsWrap` into `WrapExpr`
This nice refactoring was suggested by Simon during review:
https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13261#note_583374
Fixes #25264.
- - - - -
60dca249 by Sebastian Graf at 2024-09-17T09:19:05+02:00
Pmc: Improve Desugaring of overloaded list patterns (#25257)
This actually makes things simpler.
Fixes #25257.
- - - - -
17 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Zonk/Type.hs
- ghc/GHCi/UI/Info.hs
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
- + testsuite/tests/pmcheck/should_compile/T25257.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -569,7 +569,7 @@ mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
- {-# UNPACK #-} !(HsWrap HsExpr)
+ HsWrapper (HsExpr GhcTc)
| ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
@@ -881,7 +881,7 @@ instance Outputable XXExprGhcRn where
ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
instance Outputable XXExprGhcTc where
- ppr (WrapExpr (HsWrap co_fn e))
+ ppr (WrapExpr co_fn e)
= pprHsWrapper co_fn (\_parens -> pprExpr e)
ppr (ExpandedThingTc o e)
@@ -922,7 +922,7 @@ ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
-ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
+ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e
ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
ppr_infix_expr_tc (ConLikeTc {}) = Nothing
ppr_infix_expr_tc (HsTick {}) = Nothing
@@ -1025,7 +1025,7 @@ hsExprNeedsParens prec = go
GhcRn -> go_x_rn x
go_x_tc :: XXExprGhcTc -> Bool
- go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
+ go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e
go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
@@ -1077,7 +1077,7 @@ isAtomicHsExpr (XExpr x)
| GhcRn <- ghcPass @p = go_x_rn x
where
go_x_tc :: XXExprGhcTc -> Bool
- go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
+ go_x_tc (WrapExpr _ e) = isAtomicHsExpr e
go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -149,7 +149,7 @@ hsExprType (HsEmbTy x _) = dataConCantHappen x
hsExprType (HsQual x _ _) = dataConCantHappen x
hsExprType (HsForAll x _ _) = dataConCantHappen x
hsExprType (HsFunArr x _ _ _) = dataConCantHappen x
-hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
+hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e
hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -780,7 +780,7 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e)
+mkHsWrap co_fn e = XExpr (WrapExpr co_fn e)
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
-> HsExpr GhcTc -> HsExpr GhcTc
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -970,8 +970,8 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
fish_var (L _ (HsAppType _ e _)) = fish_var e
- fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
- return (l, e')
+ fish_var (L l (XExpr (WrapExpr _ e))) = do (l, e') <- fish_var (L l e)
+ return (l, e')
fish_var (L l (XExpr (ExpandedThingTc _ e))) = fish_var (L l e)
fish_var _ = Nothing
@@ -1019,7 +1019,7 @@ dsHsWrapped orig_hs_expr
where
go wrap (HsPar _ (L _ hs_e))
= go wrap hs_e
- go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))
+ go wrap1 (XExpr (WrapExpr wrap2 hs_e))
= go (wrap1 <.> wrap2) hs_e
go wrap (HsAppType ty (L _ hs_e) _)
= go (wrap <.> WpTyApp ty) hs_e
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -1175,7 +1175,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
- exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) =
+ exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =
wrap h h' && exp e e'
exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x'))
| isHsThingRnExpr o
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -447,7 +447,7 @@ getLHsIntegralLit (L _ e) = go e
go (XExpr (HsBinTick _ _ e)) = getLHsIntegralLit e
-- The literal might be wrapped in a case with -XOverloadedLists
- go (XExpr (WrapExpr (HsWrap _ e))) = go e
+ go (XExpr (WrapExpr _ e)) = go e
go _ = Nothing
-- | If 'Integral', extract the value and type of the overloaded literal.
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -189,6 +189,7 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
Just matches -> do
matches <- {-# SCC "desugarMatches" #-}
noCheckDs $ desugarMatches vars matches
+ tracePm "desugared matches" (ppr matches)
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
-import GHC.Builtin.Names (rationalTyConName)
+import GHC.Builtin.Names (rationalTyConName, toListName)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -44,7 +44,6 @@ import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Type
import GHC.Data.Maybe
-import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.SourceText (FractionalLit(..))
import Control.Monad (zipWithM, replicateM)
import Data.List (elemIndex)
@@ -125,21 +124,24 @@ desugarPat x pat = case pat of
XPat ext -> case ext of
ExpansionPat orig expansion -> do
- dflags <- getDynFlags
case orig of
-- We add special logic for overloaded list patterns. When:
-- - a ViewPat is the expansion of a ListPat,
- -- - RebindableSyntax is off,
-- - the type of the pattern is the built-in list type,
-- then we assume that the view function, 'toList', is the identity.
-- This improves pattern-match overload checks, as this will allow
-- the pattern match checker to directly inspect the inner pattern.
-- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).
ListPat {}
- | ViewPat arg_ty _lexpr pat <- expansion
- , not (xopt LangExt.RebindableSyntax dflags)
+ | ViewPat arg_ty lrhs pat <- expansion
, Just tc <- tyConAppTyCon_maybe arg_ty
, tc == listTyCon
+ -- `pat` looks like `coerce toList -> [p1,...,pn]`.
+ -- Now take care of -XRebindableSyntax:
+ , let is_to_list (HsVar _ (L _ to_list)) = idName to_list == toListName
+ is_to_list (XExpr (WrapExpr _ e)) = is_to_list e
+ is_to_list _ = False
+ , is_to_list (unLoc lrhs)
-> desugarLPat x pat
_ -> desugarPat x expansion
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -588,8 +588,8 @@ addTickHsExpr (HsProc x pat cmdtop) =
liftM2 (HsProc x)
(addTickLPat pat)
(traverse (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
- liftM (XExpr . WrapExpr . HsWrap w) $
+addTickHsExpr (XExpr (WrapExpr w e)) =
+ liftM (XExpr . WrapExpr w) $
(addTickHsExpr e) -- Explicitly no tick on inside
addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1328,7 +1328,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
XExpr x
| HieTc <- hiePass @p
-> case x of
- WrapExpr (HsWrap w a)
+ WrapExpr w a
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
ExpandedThingTc _ e
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -333,7 +333,7 @@ We expect to add to this list as we deal with more patterns via the expansion
mechanism.
Note [Desugaring overloaded list patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
[p1, p2, p3]
@@ -350,11 +350,12 @@ See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.
== Wrinkle ==
This is all fine, except in one very specific case:
- - when RebindableSyntax is off,
- - and the type being matched on is already a list type.
-
-In this case, it is undesirable to desugar an overloaded list pattern into
-a view pattern. To illustrate, consider the following program:
+When the type being matched on is already a list type, so that the
+pattern looks like
+ toList @[ty] dict -> pat
+then we know for certain that `toList` is an identity function, so we can
+behave exactly as if the pattern was just `pat`. This is important when
+we have `OverloadedLists`. For example (#14547, #25257)
> {-# LANGUAGE OverloadedLists #-}
>
@@ -375,6 +376,8 @@ as it isn't able to look through view patterns.
We can see that this is silly: as we are matching on a list, `toList` doesn't
actually do anything. So we ignore it, and desugar the pattern to an explicit
list pattern, instead of a view pattern.
+(NB: Because of -XRebindableSyntax we have to check that the `toList` we see is
+actually resolved to `GHC.Exts.toList`.)
Note however that this is not necessarily sound, because it is possible to have
a list `l` such that `toList l` is not the same as `l`.
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1080,10 +1080,10 @@ zonkExpr (HsQual x _ _) = dataConCantHappen x
zonkExpr (HsForAll x _ _) = dataConCantHappen x
zonkExpr (HsFunArr x _ _ _) = dataConCantHappen x
-zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))
+zonkExpr (XExpr (WrapExpr co_fn expr))
= runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn ->
do new_expr <- zonkExpr expr
- return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
+ return (XExpr (WrapExpr new_co_fn new_expr))
zonkExpr (XExpr (ExpandedThingTc thing e))
= do e' <- zonkExpr e
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -355,8 +355,8 @@ processAllTypeCheckedModule tcm
mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i
| otherwise = Nothing
- unwrapVar (XExpr (WrapExpr (HsWrap _ var))) = var
- unwrapVar e' = e'
+ unwrapVar (XExpr (WrapExpr _ var)) = var
+ unwrapVar e' = e'
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
=====================================
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
=====================================
@@ -1512,16 +1512,15 @@
[]))
(XExpr
(WrapExpr
- (HsWrap
- (WpTyApp
- (TyConApp
- ({abstract:TyCon})
- []))
- (XExpr
- (ConLikeTc
- ({abstract:ConLike})
- []
- []))))))
+ (WpTyApp
+ (TyConApp
+ ({abstract:TyCon})
+ []))
+ (XExpr
+ (ConLikeTc
+ ({abstract:ConLike})
+ []
+ [])))))
(L
(EpAnn
(EpaSpan { <no location info> })
@@ -1575,16 +1574,15 @@
[]))
(XExpr
(WrapExpr
- (HsWrap
- (WpTyApp
- (TyConApp
- ({abstract:TyCon})
- []))
- (XExpr
- (ConLikeTc
- ({abstract:ConLike})
- []
- []))))))
+ (WpTyApp
+ (TyConApp
+ ({abstract:TyCon})
+ []))
+ (XExpr
+ (ConLikeTc
+ ({abstract:ConLike})
+ []
+ [])))))
(L
(EpAnn
(EpaSpan { <no location info> })
@@ -1638,16 +1636,15 @@
[]))
(XExpr
(WrapExpr
- (HsWrap
- (WpTyApp
- (TyConApp
- ({abstract:TyCon})
- []))
- (XExpr
- (ConLikeTc
- ({abstract:ConLike})
- []
- []))))))
+ (WpTyApp
+ (TyConApp
+ ({abstract:TyCon})
+ []))
+ (XExpr
+ (ConLikeTc
+ ({abstract:ConLike})
+ []
+ [])))))
(L
(EpAnn
(EpaSpan { <no location info> })
@@ -1674,16 +1671,15 @@
[]))
(XExpr
(WrapExpr
- (HsWrap
- (WpTyApp
- (TyConApp
- ({abstract:TyCon})
- []))
- (XExpr
- (ConLikeTc
- ({abstract:ConLike})
- []
- []))))))))))))))))))))))
+ (WpTyApp
+ (TyConApp
+ ({abstract:TyCon})
+ []))
+ (XExpr
+ (ConLikeTc
+ ({abstract:ConLike})
+ []
+ [])))))))))))))))))))))
,(L
(EpAnn
(EpaSpan { <no location info> })
@@ -1750,16 +1746,15 @@
[]))
(XExpr
(WrapExpr
- (HsWrap
- (WpTyApp
- (TyConApp
- ({abstract:TyCon})
- []))
- (XExpr
- (ConLikeTc
- ({abstract:ConLike})
- []
- []))))))))))
+ (WpTyApp
+ (TyConApp
+ ({abstract:TyCon})
+ []))
+ (XExpr
+ (ConLikeTc
+ ({abstract:ConLike})
+ []
+ [])))))))))
,(L
(EpAnn
(EpaSpan { <no location info> })
=====================================
testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
=====================================
@@ -53,9 +53,9 @@ typecheckPlugin [name, "typecheck"] _ tc
typecheckPlugin _ _ tc = return tc
metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
-metaPlugin' [name, "meta"] (L l (XExpr (WrapExpr (HsWrap w (HsPar _ (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e)))))))
+metaPlugin' [name, "meta"] (L l (XExpr (WrapExpr w (HsPar _ (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e))))))
| occNameString (getOccName id) == name
- = return (L l (XExpr (WrapExpr (HsWrap w (unLoc e)))))
+ = return (L l (XExpr (WrapExpr w (unLoc e))))
-- The test should always match this first case. If the desugaring changes
-- again in the future then the panic is more useful than the previous
-- inscrutable failure.
=====================================
testsuite/tests/pmcheck/should_compile/T25257.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedLists, RebindableSyntax #-}
+{-# OPTIONS -Wincomplete-patterns #-}
+
+module T25257 where
+
+import Prelude (Bool(..), IO, print)
+import GHC.Exts (IsList(fromListN, toList))
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -172,3 +172,4 @@ test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
test('DoubleMatch', normal, compile, [overlapping_incomplete])
test('T24817', normal, compile, [overlapping_incomplete])
+test('T25257', normal, compile, [overlapping_incomplete])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7377be17d5d936ec2babaf48afdea81b27e33680...60dca24936a65a217f01c61fda54c37fd0346ab9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7377be17d5d936ec2babaf48afdea81b27e33680...60dca24936a65a217f01c61fda54c37fd0346ab9
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/20240917/6351d940/attachment-0001.html>
More information about the ghc-commits
mailing list