[Git][ghc/ghc][wip/sand-witch/improve-pat-to-ty] Improve pattern to type pattern transformation (23739)
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Thu May 2 13:25:51 UTC 2024
Andrei Borzenkov pushed to branch wip/sand-witch/improve-pat-to-ty at Glasgow Haskell Compiler / GHC
Commits:
bce3ca67 by Andrei Borzenkov at 2024-05-02T17:23:54+04:00
Improve pattern to type pattern transformation (23739)
`pat_to_type_pat` function now can handle more patterns:
- TuplePat
- ListPat
- LitPat
- NPat
- ConPat
Allowing these new constructors in type patterns significantly
increases possible shapes of type patterns without `type` keyword.
This patch also changes how lookups in `lookupOccRnConstr` are
performed, because we need to fall back into
types when we didn't find a constructor on data level to perform
`ConPat` to type transformation properly.
- - - - -
14 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Utils/Env.hs
- testsuite/tests/rename/should_fail/T19843c.stderr
- testsuite/tests/type-data/should_fail/TDPattern.stderr
- + testsuite/tests/typecheck/should_compile/T23739a.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T23739b.hs
- + testsuite/tests/typecheck/should_fail/T23739b.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -245,6 +245,14 @@ data HsTyPatRn = HsTPRn
}
deriving Data
+instance Semigroup HsTyPatRn where
+ HsTPRn nwcs1 imp_tvs1 exp_tvs1 <>
+ HsTPRn nwcs2 imp_tvs2 exp_tvs2 =
+ HsTPRn (nwcs1 ++ nwcs2) (imp_tvs1 ++ imp_tvs2) (exp_tvs1 ++ exp_tvs2)
+
+instance Monoid HsTyPatRn where
+ mempty = HsTPRn [] [] []
+
type instance XXHsPatSigType (GhcPass _) = DataConCantHappen
type instance XXHsTyPat (GhcPass _) = DataConCantHappen
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1032,7 +1032,15 @@ lookupOccRn = lookupOccRn' WL_Anything
-- lookupOccRnConstr looks up an occurrence of a RdrName and displays
-- constructors and pattern synonyms as suggestions if it is not in scope
lookupOccRnConstr :: RdrName -> RnM Name
-lookupOccRnConstr = lookupOccRn' WL_Constructor
+lookupOccRnConstr rdr_name
+ = do { mb_gre <- lookupOccRn_maybe rdr_name
+ ; case mb_gre of
+ Just gre -> return $ greName gre
+ Nothing -> do
+ { mb_ty_gre <- lookup_promoted rdr_name
+ ; case mb_ty_gre of
+ Just gre -> return $ greName gre
+ Nothing -> reportUnboundName' WL_Constructor rdr_name} }
-- lookupOccRnRecField looks up an occurrence of a RdrName and displays
-- record fields as suggestions if it is not in scope
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -56,7 +56,6 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
-import GHC.Types.SourceText
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
@@ -899,18 +898,12 @@ expr_to_type earg =
where
unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id
unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)
- go (L l e@(HsOverLit _ lit)) =
- do { tylit <- case ol_val lit of
- HsIntegral n -> return $ HsNumTy NoSourceText (il_value n)
- HsIsString _ s -> return $ HsStrTy NoSourceText s
- HsFractional _ -> failWith $ TcRnIllformedTypeArgument (L l e)
- ; return (L l (HsTyLit noExtField tylit)) }
- go (L l e@(HsLit _ lit)) =
- do { tylit <- case lit of
- HsChar _ c -> return $ HsCharTy NoSourceText c
- HsString _ s -> return $ HsStrTy NoSourceText s
- _ -> failWith $ TcRnIllformedTypeArgument (L l e)
- ; return (L l (HsTyLit noExtField tylit)) }
+ go (L l (HsOverLit _ lit))
+ | Just tylit <- tyLitFromOverloadedLit (ol_val lit)
+ = return (L l (HsTyLit noExtField tylit))
+ go (L l (HsLit _ lit))
+ | Just tylit <- tyLitFromLit lit
+ = return (L l (HsTyLit noExtField tylit))
go (L l (ExplicitTuple _ tup_args boxity))
-- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted
| isBoxed boxity
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -37,8 +37,6 @@ import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Tc.Gen.HsType
-import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
-
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
@@ -78,12 +76,10 @@ import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
-import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import Control.Monad
@@ -1164,46 +1160,11 @@ tc_infer_id id_name
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
- (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon
- ATyVar name _ -> fail_tyvar name
+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon tc -- TyCon or TcTyCon
+ ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
where
- fail_tycon tc = do
- gre <- getGlobalRdrEnv
- let nm = tyConName tc
- pprov = case lookupGRE_Name gre nm of
- Just gre -> nest 2 (pprNameProvenance gre)
- Nothing -> empty
- err | isClassTyCon tc = ClassTE
- | otherwise = TyConTE
- fail_with_msg dataName nm pprov err
-
- fail_tyvar nm =
- let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
- in fail_with_msg varName nm pprov TyVarTE
-
- fail_with_msg whatName nm pprov err = do
- (import_errs, hints) <- get_suggestions whatName
- unit_state <- hsc_units <$> getTopEnv
- let
- -- TODO: unfortunate to have to convert to SDoc here.
- -- This should go away once we refactor ErrInfo.
- hint_msg = vcat $ map ppr hints
- import_err_msg = vcat $ map ppr import_errs
- info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
- failWithTc $ TcRnMessageWithInfo unit_state (
- mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))
-
- get_suggestions ns = do
- required_type_arguments <- xoptM LangExt.RequiredTypeArguments
- if required_type_arguments && isVarNameSpace ns
- then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]
- else do
- let occ = mkOccNameFS ns (occNameFS (occName id_name))
- lcl_env <- getLocalRdrEnv
- unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ)
-
return_id id = return (HsVar noExtField (noLocA id), idType id)
{- Note [Suppress hints with RequiredTypeArguments]
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -73,7 +73,10 @@ module GHC.Tc.Gen.HsType (
HoleMode(..),
-- Error messages
- funAppCtxt, addTyConFlavCtxt
+ funAppCtxt, addTyConFlavCtxt,
+
+ -- Utils
+ tyLitFromLit, tyLitFromOverloadedLit,
) where
import GHC.Prelude hiding ( head, init, last, tail )
@@ -140,6 +143,7 @@ import qualified Data.List.NonEmpty as NE
import Data.List ( mapAccumL )
import Control.Monad
import Data.Tuple( swap )
+import GHC.Types.SourceText
{-
----------------------------
@@ -4689,3 +4693,22 @@ addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a
addTyConFlavCtxt name flav
= addErrCtxt $ hsep [ text "In the", ppr flav
, text "declaration for", quotes (ppr name) ]
+
+{-
+************************************************************************
+* *
+ Utils for constructing TyLit
+* *
+************************************************************************
+-}
+
+
+tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn)
+tyLitFromLit (HsString x str) = Just (HsStrTy x str)
+tyLitFromLit (HsChar x char) = Just (HsCharTy x char)
+tyLitFromLit _ = Nothing
+
+tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn)
+tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n)
+tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s
+tyLitFromOverloadedLit HsFractional{} = Nothing
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -504,6 +504,14 @@ tc_forall_pat tv _ pat thing_inside
; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp)
; return (pat', result) }
+lpats_to_type_pats :: [LPat GhcRn] -> TcM (HsTyPatRn, [LHsType GhcRn])
+lpats_to_type_pats = foldr step nil where
+ nil = pure (mempty, [])
+ step pat acc =
+ do { HsTP x t <- pat_to_type_pat (unLoc pat)
+ ; (xs, tys) <- acc
+ ; pure (x `mappend` xs, t : tys) }
+
-- Convert a Pat into the equivalent HsTyPat.
-- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart.
-- The `TcM` monad is only used to fail on ill-formed type patterns.
@@ -539,6 +547,41 @@ pat_to_type_pat (ParPat _ pat)
pat_to_type_pat (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do
{ HsTP x t <- pat_to_type_pat pat
; return (HsTP x (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice))) }
+
+pat_to_type_pat (TuplePat NoExtField pats Boxed)
+ = do { (x, tys) <- lpats_to_type_pats pats
+ ; let t = noLocA (HsExplicitTupleTy noExtField tys)
+ ; pure (HsTP x t) }
+pat_to_type_pat (ListPat NoExtField pats)
+ = do { (x, tys) <- lpats_to_type_pats pats
+ ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys)
+ ; pure (HsTP x t) }
+
+pat_to_type_pat (LitPat NoExtField lit)
+ | Just ty_lit <- tyLitFromLit lit
+ = do { let t = noLocA (HsTyLit noExtField ty_lit)
+ ; pure (HsTP mempty t) }
+pat_to_type_pat (NPat _ (L _ lit) _ _)
+ | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit)
+ = do { let t = noLocA (HsTyLit noExtField ty_lit)
+ ; pure (HsTP mempty t)}
+
+pat_to_type_pat (ConPat _ lname (InfixCon left right))
+ = do { HsTP xl lty <- pat_to_type_pat (unLoc left)
+ ; HsTP xr rty <- pat_to_type_pat (unLoc right)
+ ; let { t = noLocA (HsOpTy noAnn NotPromoted lty lname rty)}
+ ; pure (HsTP (xl `mappend` xr) t) }
+pat_to_type_pat (ConPat _ lname (PrefixCon invis_args vis_args))
+ = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname)
+ ; (HsTP x_invis ty_invis) = foldl' apply_invis_arg (HsTP mempty appHead) invis_args }
+ ; (x_vis, tys_vis) <- lpats_to_type_pats vis_args
+ ; let t = foldl' (\x y -> noLocA (HsAppTy noExtField x y)) ty_invis tys_vis
+ ; pure (HsTP (x_invis `mempty` x_vis) t) }
+ where
+ apply_invis_arg :: HsTyPat GhcRn -> HsConPatTyArg GhcRn -> HsTyPat GhcRn
+ apply_invis_arg (HsTP !hx !h) (HsConPatTyArg _ (HsTP argx arg))
+ = HsTP (hx `mappend` argx) (noLocA (HsAppKindTy noExtField h arg))
+
pat_to_type_pat pat =
-- There are other cases to handle (ConPat, ListPat, TuplePat, etc), but these
-- would always be rejected by the unification in `tcHsTyPat`, so it's fine to
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Tc.Utils.Env(
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, lookupGlobal_maybe,
addTypecheckedBinds,
+ failIllegalTyCon, failIllegalTyVal,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvList,
@@ -137,6 +138,7 @@ import Data.List ( intercalate )
import Control.Monad
import GHC.Iface.Errors.Types
import GHC.Types.Error
+import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
{- *********************************************************************
* *
@@ -278,6 +280,7 @@ tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
+ ATyCon tc -> failIllegalTyCon tc
_ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -349,6 +352,45 @@ tcGetInstEnvs = do { eps <- getEps
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
+-- Illegal term-level use of type things
+failIllegalTyCon :: TyCon -> TcM a
+failIllegalTyVal :: Name -> TcM a
+(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
+ where
+ fail_tycon tc = do
+ gre <- getGlobalRdrEnv
+ let nm = tyConName tc
+ pprov = case lookupGRE_Name gre nm of
+ Just gre -> nest 2 (pprNameProvenance gre)
+ Nothing -> empty
+ err | isClassTyCon tc = ClassTE
+ | otherwise = TyConTE
+ fail_with_msg dataName nm pprov err
+
+ fail_tyvar nm =
+ let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
+ in fail_with_msg varName nm pprov TyVarTE
+
+ fail_with_msg whatName nm pprov err = do
+ (import_errs, hints) <- get_suggestions whatName nm
+ unit_state <- hsc_units <$> getTopEnv
+ let
+ -- TODO: unfortunate to have to convert to SDoc here.
+ -- This should go away once we refactor ErrInfo.
+ hint_msg = vcat $ map ppr hints
+ import_err_msg = vcat $ map ppr import_errs
+ info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
+ failWithTc $ TcRnMessageWithInfo unit_state (
+ mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))
+
+ get_suggestions ns nm = do
+ required_type_arguments <- xoptM LangExt.RequiredTypeArguments
+ if required_type_arguments && isVarNameSpace ns
+ then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]
+ else do
+ let occ = mkOccNameFS ns (occNameFS (occName nm))
+ lcl_env <- getLocalRdrEnv
+ unknownNameSuggestions lcl_env WL_Constructor (mkRdrUnqual occ)
{-
************************************************************************
* *
=====================================
testsuite/tests/rename/should_fail/T19843c.stderr
=====================================
@@ -1,4 +1,7 @@
+T19843c.hs:6:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Map’
+ • imported from ‘Data.Map’ at T19843c.hs:3:1-22
+ (and originally defined in ‘Data.Map.Internal’)
+ • In the pattern: Map k v
+ In an equation for ‘foo’: foo (Map k v) = undefined
-T19843c.hs:6:6: error: [GHC-76037]
- Not in scope: data constructor ‘Map.Map’
- NB: the module ‘Data.Map’ does not export ‘Map’.
=====================================
testsuite/tests/type-data/should_fail/TDPattern.stderr
=====================================
@@ -1,3 +1,6 @@
+TDPattern.hs:7:3: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Zero’
+ • defined at TDPattern.hs:4:17
+ • In the pattern: Zero
+ In an equation for ‘f’: f Zero = 0
-TDPattern.hs:7:3: [GHC-76037]
- Not in scope: data constructor ‘Zero’
=====================================
testsuite/tests/typecheck/should_compile/T23739a.hs
=====================================
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeAbstractions,
+ ExplicitNamespaces,
+ RequiredTypeArguments,
+ DataKinds,
+ NoListTuplePuns,
+ OverloadedStrings #-}
+
+module T where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+f1 :: forall a -> a ~ (Int, Bool) => Unit
+f1 (b,c) = ()
+
+f2 :: forall a -> a ~ (Int : Bool : Double : []) => Unit
+f2 [a,b,c] = ()
+
+f3 :: forall a -> a ~ [Int, Bool, Double] => Unit
+f3 [a,b,c] = ()
+
+f4 :: forall a -> a ~ [Int, Bool, Double] => Unit
+f4 (a : b : c : []) = ()
+
+f5 :: forall a -> a ~ "blah" => Unit
+f5 "blah" = ()
+
+f6 :: forall a -> a ~ 'c' => Unit
+f6 'c' = ()
+
+f7 :: forall a -> a ~ UnconsSymbol "blah" => Unit
+f7 (Just ('b', "lah")) = ()
+
+f8 :: forall a -> Unit
+f8 _ = ()
+
+f9 :: forall a -> a ~ 42 => Unit
+f9 42 = ()
+
+f10 :: forall a -> a ~ () => Unit
+f10 () = ()
+
+f11 :: forall a -> a ~ Int => Unit
+f11 Int = ()
+
+data Tup a = MkTup a a
+
+f12 :: forall a -> a ~ (Int, MkTup 'f' 'g', 42, True, [1,2,3,4,5], (), "blah", "wombat", 'd', UnconsSymbol "corner") => Unit
+f12 (Int, 'f' `MkTup` 'g', 42, True, 1 : 2 : 3 : [4,5], () ,"blah", x, 'd', Just ('c', "orner")) = ()
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -915,3 +915,4 @@ test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-c
test('T24470b', normal, compile, [''])
test('T24566', [], makefile_test, [])
test('T23764', normal, compile, [''])
+test('T23739a', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_fail/T23739b.hs
=====================================
@@ -0,0 +1,14 @@
+
+module T23739b where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g1 :: Int -> Unit
+g1 Int = ()
+
+g2 :: Int
+g2 = Int{}
+
+g3 :: Int
+g3 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739b.stderr
=====================================
@@ -0,0 +1,21 @@
+T23739b.hs:8:4: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the pattern: Int
+ In an equation for ‘g1’: g1 Int = ()
+
+T23739b.hs:11:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int {}
+ In an equation for ‘g2’: g2 = Int {}
+
+T23739b.hs:14:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int
+ In an equation for ‘g3’: g3 = Int
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -725,4 +725,4 @@ test('T17594g', normal, compile_fail, [''])
test('T24470a', normal, compile_fail, [''])
test('T24553', normal, compile_fail, [''])
-
+test('T23739b', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bce3ca671a6f6da6df207cb06b9a9b04c3d51f48
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bce3ca671a6f6da6df207cb06b9a9b04c3d51f48
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/20240502/b9731a82/attachment-0001.html>
More information about the ghc-commits
mailing list