Commit 1132602f authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Use splitLHs{ForAll,Sigma}TyInvis throughout the codebase

Richard points out in #17688 that we use `splitLHsForAllTy` and
`splitLHsSigmaTy` in places that we ought to be using the
corresponding `-Invis` variants instead, identifying two bugs
that are caused by this oversight:

* Certain TH-quoted type signatures, such as those that appear in
  quoted `SPECIALISE` pragmas, silently turn visible `forall`s into
  invisible `forall`s.
* When quoted, the type `forall a -> (a ~ a) => a` will turn into
  `forall a -> a` due to a bug in `DsMeta.repForall` that drops
  contexts that follow visible `forall`s.

These are both ultimately caused by the fact that `splitLHsForAllTy`
and `splitLHsSigmaTy` split apart visible `forall`s in addition to
invisible ones. This patch cleans things up:

* We now use `splitLHsForAllTyInvis` and `splitLHsSigmaTyInvis`
  throughout the codebase. Relatedly, the `splitLHsForAllTy` and
  `splitLHsSigmaTy` have been removed, as they are easy to misuse.
* `DsMeta.repForall` now only handles invisible `forall`s to reduce
  the chance for confusion with visible `forall`s, which need to be
  handled differently. I also renamed it from `repForall` to
  `repForallT` to emphasize that its distinguishing characteristic
  is the fact that it desugars down to `L.H.TH.Syntax.ForallT`.

Fixes #17688.
parent 0940b59a
...@@ -56,8 +56,7 @@ module GHC.Hs.Types ( ...@@ -56,8 +56,7 @@ module GHC.Hs.Types (
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy, splitLHsPatSynTy,
splitLHsForAllTy, splitLHsForAllTyInvis, splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,
splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis,
splitHsFunType, hsTyGetAppHead_maybe, splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType, ignoreParens, hsSigType, hsSigWcType,
...@@ -1237,21 +1236,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) ...@@ -1237,21 +1236,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
(provs, ty4) = splitLHsQualTy ty3 (provs, ty4) = splitLHsQualTy ty3
-- | Decompose a sigma type (of the form @forall <tvs>. context => body@) -- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
-- into its constituent parts. -- into its constituent parts. Note that only /invisible/ @forall@s
-- -- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
-- Note that this function looks through parentheses, so it will work on types -- (i.e., @forall a ->@, with an arrow) are left untouched.
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsSigmaTy :: LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy ty
| (tvs, ty1) <- splitLHsForAllTy ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
-- | Like 'splitLHsSigmaTy', but only splits type variable binders that were
-- quantified invisibly (e.g., @forall a.@, with a dot).
-- --
-- This function is used to split apart certain types, such as instance -- This function is used to split apart certain types, such as instance
-- declaration types, which disallow visible @forall@s. For instance, if GHC -- declaration types, which disallow visible @forall@s. For instance, if GHC
...@@ -1269,20 +1256,10 @@ splitLHsSigmaTyInvis ty ...@@ -1269,20 +1256,10 @@ splitLHsSigmaTyInvis ty
, (ctxt, ty2) <- splitLHsQualTy ty1 , (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2) = (tvs, ctxt, ty2)
-- | Decompose a type of the form @forall <tvs>. body@) into its constituent -- | Decompose a type of the form @forall <tvs>. body@ into its constituent
-- parts. -- parts. Note that only /invisible/ @forall@s
-- -- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
-- Note that this function looks through parentheses, so it will work on types -- (i.e., @forall a ->@, with an arrow) are left untouched.
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy body = ([], body)
-- | Like 'splitLHsForAllTy', but only splits type variable binders that
-- were quantified invisibly (e.g., @forall a.@, with a dot).
-- --
-- This function is used to split apart certain types, such as instance -- This function is used to split apart certain types, such as instance
-- declaration types, which disallow visible @forall@s. For instance, if GHC -- declaration types, which disallow visible @forall@s. For instance, if GHC
......
...@@ -1834,7 +1834,7 @@ rnLDerivStrategy doc mds thing_inside ...@@ -1834,7 +1834,7 @@ rnLDerivStrategy doc mds thing_inside
do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
let HsIB { hsib_ext = via_imp_tvs let HsIB { hsib_ext = via_imp_tvs
, hsib_body = via_body } = via_ty' , hsib_body = via_body } = via_ty'
(via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body
via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs
via_tvs = via_imp_tvs ++ via_exp_tvs via_tvs = via_imp_tvs ++ via_exp_tvs
(thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
......
...@@ -349,7 +349,7 @@ get_scoped_tvs (L _ signature) ...@@ -349,7 +349,7 @@ get_scoped_tvs (L _ signature)
-- here 'k' scopes too -- here 'k' scopes too
| HsIB { hsib_ext = implicit_vars | HsIB { hsib_ext = implicit_vars
, hsib_body = hs_ty } <- sig , hsib_body = hs_ty } <- sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
= implicit_vars ++ hsLTyVarNames explicit_vars = implicit_vars ++ hsLTyVarNames explicit_vars
get_scoped_tvs_from_sig (XHsImplicitBndrs nec) get_scoped_tvs_from_sig (XHsImplicitBndrs nec)
= noExtCon nec = noExtCon nec
...@@ -1240,7 +1240,7 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt ...@@ -1240,7 +1240,7 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
repHsSigType (HsIB { hsib_ext = implicit_tvs repHsSigType (HsIB { hsib_ext = implicit_tvs
, hsib_body = body }) , hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body
= addSimpleTyVarBinds implicit_tvs $ = addSimpleTyVarBinds implicit_tvs $
-- See Note [Don't quantify implicit type variables in quotes] -- See Note [Don't quantify implicit type variables in quotes]
addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
...@@ -1264,21 +1264,29 @@ repLTys tys = mapM repLTy tys ...@@ -1264,21 +1264,29 @@ repLTys tys = mapM repLTy tys
repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
repLTy ty = repTy (unLoc ty) repLTy ty = repTy (unLoc ty)
repForall :: ForallVisFlag -> HsType GhcRn -> MetaM (Core (M TH.Type)) -- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
-- Arg of repForall is always HsForAllTy or HsQualTy -- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
repForall fvf ty -- In other words, the argument to this function is always an
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) -- @HsForAllTy ForallInvis@ or @HsQualTy@.
-- Types headed by visible foralls (which are desugared to ForallVisT) are
-- handled separately in repTy.
repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
repForallT ty
| (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)
= addHsTyVarBinds tvs $ \bndrs -> = addHsTyVarBinds tvs $ \bndrs ->
do { ctxt1 <- repLContext ctxt do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau ; tau1 <- repLTy tau
; case fvf of ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
ForallVis -> repTForallVis bndrs ty1 -- forall a -> {...}
ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}
} }
repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =
repTy ty@(HsQualTy {}) = repForall ForallInvis ty case fvf of
ForallInvis -> repForallT ty
ForallVis -> addHsTyVarBinds tvs $ \bndrs ->
do body1 <- repLTy body
repTForallVis bndrs body1
repTy ty@(HsQualTy {}) = repForallT ty
repTy (HsTyVar _ _ (L _ n)) repTy (HsTyVar _ _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar | isLiftedTypeKindTyConName n = repTStar
......
...@@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn ...@@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
= [ null theta = [ null theta
| TcIdSig (PartialSig { psig_hs_ty = hs_ty }) | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
<- mapMaybe sig_fn (collectHsBindListBinders lbinds) <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
, let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]
has_partial_sigs = not (null partial_sig_mrs) has_partial_sigs = not (null partial_sig_mrs)
......
...@@ -717,7 +717,7 @@ tcStandaloneDerivInstType ...@@ -717,7 +717,7 @@ tcStandaloneDerivInstType
tcStandaloneDerivInstType ctxt tcStandaloneDerivInstType ctxt
(HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
, hsib_body = deriv_ty_body })}) , hsib_body = deriv_ty_body })})
| (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body
, L _ [wc_pred] <- theta , L _ [wc_pred] <- theta
, L wc_span (HsWildCardTy _) <- ignoreParens wc_pred , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
= do dfun_ty <- tcHsClsInstType ctxt $ = do dfun_ty <- tcHsClsInstType ctxt $
......
...@@ -3131,7 +3131,7 @@ tcHsPartialSigType ctxt sig_ty ...@@ -3131,7 +3131,7 @@ tcHsPartialSigType ctxt sig_ty
| HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_ext = implicit_hs_tvs , HsIB { hsib_ext = implicit_hs_tvs
, hsib_body = hs_ty } <- ib_ty , hsib_body = hs_ty } <- ib_ty
, (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty
= addSigCtxt ctxt hs_ty $ = addSigCtxt ctxt hs_ty $
do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
<- solveLocalEqualities "tcHsPartialSigType" $ <- solveLocalEqualities "tcHsPartialSigType" $
......
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T17688a where
import Language.Haskell.TH
import System.IO
$( do ty <- [d| {-# SPECIALISE id :: forall a -> a -> a #-} |]
runIO $ hPutStrLn stderr $ pprint ty
return [] )
{-# SPECIALISE GHC.Base.id :: forall a_0 -> a_0 -> a_0 #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T17688b where
import Data.Kind
import Language.Haskell.TH hiding (Type)
import System.IO
$(do decs <- [d| type T :: forall (a :: Type) -> (a ~ a) => Type
data T x |]
runIO $ hPutStrLn stderr $ pprint decs
return [] )
type T_0 :: forall (a_1 :: *) -> a_1 ~ a_1 => *
data T_0 x_2
...@@ -496,5 +496,7 @@ test('T17379b', normal, compile_fail, ['']) ...@@ -496,5 +496,7 @@ test('T17379b', normal, compile_fail, [''])
test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T17511', normal, compile, ['']) test('T17511', normal, compile, [''])
test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T17688a', normal, compile, [''])
test('T17688b', normal, compile, [''])
test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques']) test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
test('TH_StringLift', normal, compile, ['']) test('TH_StringLift', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment