[Git][ghc/ghc][wip/T21623] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Sep 23 16:42:50 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
00011c3c by Simon Peyton Jones at 2022-09-23T17:44:46+01:00
More wibbles
- - - - -
13 changed files:
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Types/Basic.hs
- testsuite/tests/ghci/scripts/T16575.stdout
- testsuite/tests/simplCore/should_compile/T12603.stdout
- testsuite/tests/simplCore/should_compile/T15631.stdout
Changes:
=====================================
compiler/GHC/Core/ConLike.hs
=====================================
@@ -185,10 +185,14 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
--
-- 7) The original result type
conLikeFullSig :: ConLike
- -> ([TyVar], [TyCoVar], [EqSpec]
+ -> ([TyVar], [TyCoVar]
-- Why tyvars for universal but tycovars for existential?
-- See Note [Existential coercion variables] in GHC.Core.DataCon
- , ThetaType, ThetaType, [Scaled Type], Type)
+ , [EqSpec]
+ , ThetaType -- Provided theta
+ , ThetaType -- Required theta
+ , [Scaled Type] -- Arguments
+ , Type ) -- Result
conLikeFullSig (RealDataCon con) =
let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
-- Required theta is empty as normal data cons require no additional
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1610,9 +1610,9 @@ lintTyCoBndr tcv thing_inside
-- See (FORALL1) and (FORALL2) in GHC.Core.Type
; if (isTyVar tcv)
then -- Check that in (forall (a:ki). blah) we have ki:Type
- lintL (tcIsLiftedTypeKind (typeKind tcv_type')) $
- hang (text "TyCoVar whose kind does not have kind Type")
- 2 (ppr tcv' <+> dcolon <+> ppr (typeKind tcv_type'))
+ lintL (isLiftedTypeKind (typeKind tcv_type')) $
+ hang (text "TyVar whose kind does not have kind Type:")
+ 2 (ppr tcv' <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr (typeKind tcv_type'))
else -- Check that in (forall (cv::ty). blah),
-- then ty looks like (t1 ~# t2)
lintL (isCoVarType tcv_type') $
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -664,7 +664,7 @@ kindRep_maybe kind
| Just (_, rep) <- sORTKind_maybe kind = Just rep
| otherwise = Nothing
--- | Returns True if the argument is a lifted type or constraint
+-- | Returns True if the argument is (lifted) Type or Constraint
-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind kind
@@ -2517,38 +2517,19 @@ seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
Note [Kinding rules for types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here are the kinding rules for types
-
- torc1 is TYPE or CONSTRAINT
- torc2 is TYPE or CONSTRAINT
- t1 : torc1 rep1
- t2 : torc2 rep2
- (FUN) ----------------
- t1 -> t2 : torc2 LiftedRep
-
- ty : TYPE rep
- `a` is not free in rep
-(FORALL) -----------------------
- forall a. ty : TYPE rep
-
- t1 : TYPE rep1
- t2 : TYPE rep2
- (FUN) ----------------
- t1 -> t2 : Type
-
- t1 : Constraint
- t2 : TYPE rep
- (PRED1) ----------------
- t1 => t2 : Type
-
- t1 : Constraint
- t2 : Constraint
- (PRED2) ---------------------
- t1 => t2 : Constraint
+Here are the key kinding rules for types
+
+ torc1 is TYPE or CONSTRAINT
+ torc2 is TYPE or CONSTRAINT
+ t1 : torc1 rep1
+ t2 : torc2 rep2
+ (FUN) ----------------
+ t1 -> t2 : torc2 LiftedRep
torc is TYPE or CONSTRAINT
ty : body_torc rep
- ki : Type
+ bndr_torc is Type or Constraint
+ ki : bndr_torc
`a` is a type variable
`a` is not free in rep
(FORALL1) -----------------------
@@ -2556,6 +2537,7 @@ Here are the kinding rules for types
torc is TYPE or CONSTRAINT
ty : body_torc rep
+ `c` is a coercion variable
`c` is not free in rep
`c` is free in ty -- Surprise 1!
(FORALL2) -------------------------
@@ -2565,6 +2547,10 @@ Here are the kinding rules for types
Note that:
* (FORALL1) rejects (forall (a::Maybe). blah)
+* (FORALL1) accepts (forall (a :: t1~t2) blah), where the type variable
+ (not coercion variable!) 'a' has a kind (t1~t2) that in turn has kind
+ Constraint. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep.
+
* (FORALL2) Surprise 1:
See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -388,11 +388,11 @@ deriving instance Data (HsUntypedSplice GhcPs)
deriving instance Data (HsUntypedSplice GhcRn)
deriving instance Data (HsUntypedSplice GhcTc)
-deriving instance Data (HsUntypedSpliceResult (HsExpr GhcRn))
+--deriving instance Data (HsUntypedSpliceResult (HsExpr GhcRn))
-deriving instance Data (HsUntypedSpliceResult (Pat GhcRn))
+--deriving instance Data (HsUntypedSpliceResult (Pat GhcRn))
-deriving instance Data (HsUntypedSpliceResult (HsType GhcRn))
+deriving instance Data a => Data (HsUntypedSpliceResult a)
-- deriving instance (DataIdLR p p) => Data (HsQuote p)
deriving instance Data (HsQuote GhcPs)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -316,7 +316,7 @@ type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn]
type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives
type instance XSpliceTy GhcPs = NoExtField
-type instance XSpliceTy GhcRn = HsUntypedSpliceResult (HsType GhcRn)
+type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn)
type instance XSpliceTy GhcTc = Kind
type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn]
@@ -1139,8 +1139,7 @@ ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
-ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprTrace "ppr_mono" (ppr name) $
- pprOccWithTick Prefix prom name
+ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name
ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys)
-- Special-case unary boxed tuples so that they are pretty-printed as
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
-import GHC.Types.Basic ( TopLevelFlag, isTopLevel )
+import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
import GHC.Unit.Module
@@ -673,23 +673,31 @@ rnSpliceType splice
= ( makePending UntypedTypeSplice name rn_splice
, HsSpliceTy (HsUntypedSpliceNested name) rn_splice)
+ run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
run_type_splice rn_splice
= do { traceRn "rnSpliceType: untyped type splice" empty
; (hs_ty2, mod_finalizers) <-
runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2 }
- -- checkNoErrs: see Note [Renamer errors]
+ -- checkNoErrs: see Note [Renamer errors]
+
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( HsParTy noAnn
- $ flip HsSpliceTy rn_splice
- . HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
- <$> hs_ty3
+ ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
+ (mb_paren hs_ty3))
+ rn_splice
, fvs
) }
-- Wrap the result of the splice in parens so that we don't
-- lose the outermost location set by runQuasiQuote (#7918)
+ -- Wrap a non-atomic result in HsParTy parens;
+ -- but not if it's atomic to avoid double parens for operators
+ mb_paren :: LHsType GhcRn -> LHsType GhcRn
+ mb_paren lhs_ty@(L loc hs_ty)
+ | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)
+ | otherwise = lhs_ty
+
{- Note [Partial Type Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial Type Signatures are partially supported in TH type splices: only
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1046,7 +1046,7 @@ tc_infer_hs_type mode (HsKindSig _ ty sig)
--
-- See Note [Delaying modFinalizers in untyped splices].
tc_infer_hs_type mode (HsSpliceTy (HsUntypedSpliceTop _ ty) _)
- = tc_infer_hs_type mode ty
+ = tc_infer_lhs_type mode ty
tc_infer_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) = pprPanic "tc_infer_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)
@@ -1150,7 +1150,7 @@ tc_hs_type _ ty@(HsRecTy {}) _
tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _)
exp_kind
= do addModFinalizersWithLclEnv mod_finalizers
- tc_hs_type mode ty exp_kind
+ tc_lhs_type mode ty exp_kind
tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -316,7 +316,7 @@ no_anon_wc_ty lty = go lty
&& go ty
HsQualTy { hst_ctxt = ctxt
, hst_body = ty } -> gos (unLoc ctxt) && go ty
- HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go $ L noSrcSpanA ty
+ HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty
HsSpliceTy (HsUntypedSpliceNested _) _ -> True
HsTyLit{} -> True
HsTyVar{} -> True
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -85,8 +85,6 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
-import GHC.Utils.Trace
-
{-
************************************************************************
* *
@@ -887,8 +885,7 @@ mkRecSelBind (tycon, fl)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
-> (Id, LHsBind GhcRn)
mkOneRecordSelector all_cons idDetails fl has_sel
- = pprTrace "mkOneRec" (ppr con1 $$ ppr sel_name $$ ppr field_ty $$ ppr data_ty $$ ppr is_naughty)
- (sel_id, L (noAnnSrcSpan loc) sel_bind)
+ = (sel_id, L (noAnnSrcSpan loc) sel_bind)
where
loc = getSrcSpan sel_name
loc' = noAnnSrcSpan loc
@@ -1039,9 +1036,28 @@ helpfully, rather than saying unhelpfully that 'x' is not in scope.
Hence the sel_naughty flag, to identify record selectors that don't really exist.
In general, a field is "naughty" if its type mentions a type variable that
-isn't in the result type of the constructor. Note that this *allows*
-GADT record selectors (Note [GADT record selectors]) whose types may look
-like sel :: T [a] -> a
+isn't in
+ * the (original, user-written) result type of the constructor, or
+ * the "required theta" for the constructor
+
+Note that this *allows* GADT record selectors (Note [GADT record
+selectors]) whose types may look like sel :: T [a] -> a
+
+The "required theta" part is illustrated by test patsyn/should_run/records_run
+where we have
+
+ pattern ReadP :: Read a => a -> String
+ pattern ReadP {readp} <- (read -> readp)
+
+The selector is defined like this:
+
+ $selreadp :: ReadP a => String -> a
+ $selReadP s = readp s
+
+Perfectly fine! The (ReadP a) constraint lets us contructor a value
+of type 'a' from a bare String. NB: "required theta" is empty for
+data cons (see conLikeFullSig), so this reasoning only bites for
+patttern synonyms.
For naughty selectors we make a dummy binding
sel = ()
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -49,7 +49,8 @@ module GHC.Types.Basic (
CbvMark(..), isMarkedCbv,
- PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,
+ PprPrec(..), topPrec, sigPrec, opPrec, funPrec,
+ starPrec, appPrec, maxPrec,
maybeParen,
TupleSort(..), tupleSortBoxity, boxityTupleSort,
@@ -744,16 +745,17 @@ pprSafeOverlap False = empty
newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
-- See Note [Precedence in types]
-topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec
-topPrec = PprPrec 0 -- No parens
-sigPrec = PprPrec 1 -- Explicit type signatures
-funPrec = PprPrec 2 -- Function args; no parens for constructor apps
- -- See [Type operator precedence] for why both
- -- funPrec and opPrec exist.
-opPrec = PprPrec 2 -- Infix operator
+topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec
+topPrec = PprPrec 0 -- No parens
+sigPrec = PprPrec 1 -- Explicit type signatures
+funPrec = PprPrec 2 -- Function args; no parens for constructor apps
+ -- See [Type operator precedence] for why both
+ -- funPrec and opPrec exist.
+opPrec = PprPrec 2 -- Infix operator
starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)
-- See Note [Star kind precedence]
appPrec = PprPrec 4 -- Constructor args; no parens for atomic
+maxPrec = appPrec -- Maximum precendence
maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
maybeParen ctxt_prec inner_prec pretty
=====================================
testsuite/tests/ghci/scripts/T16575.stdout
=====================================
@@ -1,5 +1,4 @@
-Loaded package environment from /home/simonpj/.ghc/x86_64-linux-9.5.20220920/environments/default
-GHCi, version 9.5.20220920: https://www.haskell.org/ghc/ :? for help
+GHCi, version 9.5.20220917: https://www.haskell.org/ghc/ :? for help
ghci> ghci> [1 of 1] Compiling Ghost ( T16575.hs, interpreted )
Ok, one module loaded.
Collecting type info for 1 module(s) ...
@@ -9,15 +8,15 @@ T16575.hs:(4,15)-(4,18): [Ghost.X] -> GHC.Show.ShowS
T16575.hs:(7,7)-(7,8): Ghost.X -> Ghost.X -> GHC.Types.Bool
T16575.hs:(6,10)-(6,13): Ghost.X -> Ghost.X -> GHC.Types.Bool
T16575.hs:(4,15)-(4,18): GHC.Show.Show Ghost.X
-T16575.hs:(4,15)-(4,18): ([Ghost.X] -> GHC.Show.ShowS) -> GHC.Show.Show Ghost.X
-T16575.hs:(4,15)-(4,18): (Ghost.X -> GHC.Base.String) -> ([Ghost.X] -> GHC.Show.ShowS) -> GHC.Show.Show Ghost.X
-T16575.hs:(4,15)-(4,18): (GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS) -> (Ghost.X -> GHC.Base.String) -> ([Ghost.X] -> GHC.Show.ShowS) -> GHC.Show.Show Ghost.X
+T16575.hs:(4,15)-(4,18): ([Ghost.X] -> GHC.Show.ShowS) -=> GHC.Show.Show Ghost.X
+T16575.hs:(4,15)-(4,18): (Ghost.X -> GHC.Base.String) -=> ([Ghost.X] -> GHC.Show.ShowS) -=> GHC.Show.Show Ghost.X
+T16575.hs:(4,15)-(4,18): (GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS) -=> (Ghost.X -> GHC.Base.String) -=> ([Ghost.X] -> GHC.Show.ShowS) -=> GHC.Show.Show Ghost.X
T16575.hs:(4,15)-(4,18): GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS
T16575.hs:(4,15)-(4,18): Ghost.X -> GHC.Base.String
T16575.hs:(4,15)-(4,18): [Ghost.X] -> GHC.Show.ShowS
T16575.hs:(6,10)-(6,13): GHC.Classes.Eq Ghost.X
-T16575.hs:(6,10)-(6,13): (Ghost.X -> Ghost.X -> GHC.Types.Bool) -> GHC.Classes.Eq Ghost.X
-T16575.hs:(6,10)-(6,13): (Ghost.X -> Ghost.X -> GHC.Types.Bool) -> (Ghost.X -> Ghost.X -> GHC.Types.Bool) -> GHC.Classes.Eq Ghost.X
+T16575.hs:(6,10)-(6,13): (Ghost.X -> Ghost.X -> GHC.Types.Bool) -=> GHC.Classes.Eq Ghost.X
+T16575.hs:(6,10)-(6,13): (Ghost.X -> Ghost.X -> GHC.Types.Bool) -=> (Ghost.X -> Ghost.X -> GHC.Types.Bool) -=> GHC.Classes.Eq Ghost.X
T16575.hs:(6,10)-(6,13): Ghost.X -> Ghost.X -> GHC.Types.Bool
T16575.hs:(6,10)-(6,13): Ghost.X -> Ghost.X -> GHC.Types.Bool
T16575.hs:(7,14)-(7,17): GHC.Types.Bool
=====================================
testsuite/tests/simplCore/should_compile/T12603.stdout
=====================================
@@ -1 +1 @@
-lvl = case GHC.Real.$wf1 2# 8# of v { __DEFAULT -> GHC.Types.I# v }
+ = case GHC.Real.$wf1 2# 8# of v { __DEFAULT ->
=====================================
testsuite/tests/simplCore/should_compile/T15631.stdout
=====================================
@@ -1,7 +1,7 @@
case GHC.List.$wlenAcc @a (Foo.f2 @a) 0# of v { __DEFAULT ->
case GHC.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT ->
case GHC.List.reverse1 @a xs (GHC.Types.[] @a) of {
- [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 };
+ case Foo.f1 @a of { GHC.Types.MkIntBox v1 -> GHC.Prim.+# ww1 v1 };
case GHC.List.$wlenAcc
case Foo.$wf @a xs of ww [Occ=Once1] { __DEFAULT ->
case Foo.$wf @a xs of ww { __DEFAULT -> GHC.Types.I# ww }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/00011c3c6fcbb9ebfbe8a954860d80ebefd4d99c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/00011c3c6fcbb9ebfbe8a954860d80ebefd4d99c
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/20220923/17e7ba41/attachment-0001.html>
More information about the ghc-commits
mailing list