Commit fc8959ac authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor LHsTyVarBndrs to fix Trac #6081

This is really a small change, but it touches a lot of files quite
significantly. The real goal is to put the implicitly-bound kind
variables of a data/class decl in the right place, namely on the
LHsTyVarBndrs type, which now looks like

  data LHsTyVarBndrs name
    = HsQTvs { hsq_kvs :: [Name]
             , hsq_tvs :: [LHsTyVarBndr name]
      }

This little change made the type checker neater in a number of
ways, but it was fiddly to push through the changes.
parent c1e928e4
......@@ -150,7 +150,8 @@ repTopDs group
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs]
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
, tv <- hsQTvBndrs qtvs]
where
sigs = case binds of
ValBindsIn _ sigs -> sigs
......@@ -214,9 +215,8 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
do { flav <- repFamilyFlavour flavour
; case opt_kind of
Nothing -> repFamilyNoKind flav tc1 bndrs
Just (HsBSig ki _)
-> do { ki1 <- repKind ki
; repFamilyKind flav tc1 bndrs ki1 }
Just ki -> do { ki1 <- repKind ki
; repFamilyKind flav tc1 bndrs ki1 }
}
; return $ Just (loc, dec)
}
......@@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
; repTySyn tc bndrs opt_tys ty1 }
-------------------------
mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name]
-> HsTyDefn Name -> DsM [LHsTyVarBndr Name]
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
-> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
-- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
mk_extra_tvs tc tvs defn
| TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn
| TyData { td_kindSig = Just hs_kind } <- defn
= do { extra_tvs <- go hs_kind
; return (tvs ++ extra_tvs) }
; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) }
| otherwise
= return tvs
where
......@@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) }
; hs_tv = L loc (KindedTyVar nm kind) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
......@@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
-- the selector Ids, not to fresh names (Trac #5410)
--
do { cxt1 <- repContext cxt
; cls_tcon <- repTy (HsTyVar cls)
; cls_tcon <- repTy (HsTyVar (unLoc cls))
; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
......@@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
; repInst cxt1 inst_ty1 decls }
; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
repFamInstD (FamInstDecl { fid_tycon = tc_name
, fid_pats = HsBSig tys (kv_names, tv_names)
, fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
, fid_defn = defn })
= WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind
-- polymorphism in Template Haskell (sigh)
do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name
hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk
hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names) -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
......@@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
-------------------------------------------------------
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
, con_details = details, con_res = ResTyH98 }))
| null (hsQTvBndrs con_tvs)
= do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
; repConstr con1 details }
repC tvs (L _ (ConDecl { con_name = con
......@@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con
, con_details = details
, con_res = res_ty }))
= do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
; binds <- mapM dupBinder con_tv_subst
; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
......@@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm
rep_ty (HsForAllTy Explicit tvs ctxt ty)
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
; bndrs1 <- mapM rep_in_scope_tv tvs
; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
; bndrs2 <- coreList tyVarBndrTyConName bndrs1
; ctxt1 <- repLContext ctxt
; ty1 <- repLTy ty
......@@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
-- Types
-------------------------------------------------------
addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment;
......@@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be
addTyVarBinds tvs m
= do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames)
do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 }
; wrapGenSyms freshNames term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: [LHsTyVarBndr Name]
addTyClTyVarBinds :: LHsTyVarBndrs Name
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
-> DsM (Core (TH.Q a))
......@@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m
-- This makes things work for family declarations
; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr tvs
do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 }
......@@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
= repKind ki >>= repKindedTV nm
-- represent a type context
......
......@@ -275,7 +275,7 @@ cvt_ci_decs doc decs
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName
, Located RdrName
, [LHsTyVarBndr RdrName])
, LHsTyVarBndrs RdrName)
cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
......@@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName
, Located RdrName
, HsBndrSig [LHsType RdrName])
, HsWithBndrs [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tys' <- mapM cvtType tys
; return (cxt', tc', mkHsBSig tys') }
; return (cxt', tc', mkHsWithBndrs tys') }
-------------------------------------------------------------------
-- Partitioning declarations
......@@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con
; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
, con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
......@@ -759,7 +759,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (mkHsBSig t') }
; return $ SigPatIn p' (mkHsWithBndrs t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
......@@ -784,8 +784,8 @@ cvtOpAppP x op y
-----------------------------------------------------------
-- Types and type variables
cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
cvtTvs tvs = mapM cvt_tv tvs
cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
......@@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm)
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' (mkHsBSig ki') }
; returnL $ KindedTyVar nm' ki' }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......@@ -845,7 +845,7 @@ cvtType ty
-> do { tvs' <- cvtTvs tvs
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
}
SigT ty ki
......@@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do
k2' <- cvtKind k2
returnL (HsFunTy k1' k2')
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
; return (Just (mkHsBSig ki')) }
; return (Just ki') }
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
......
......@@ -428,20 +428,20 @@ data TyClDecl name
| -- | @type/data family T :: *->*@
TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind
tcdTyVars :: LHsTyVarBndrs name, -- type variables
tcdKindSig :: Maybe (LHsKind name) -- result kind
}
| -- | @type/data declaration
TyDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: [LHsTyVarBndr name]
, tcdTyVars :: LHsTyVarBndrs name
, tcdTyDefn :: HsTyDefn name
, tcdFVs :: NameSet }
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class
tcdTyVars :: [LHsTyVarBndr name], -- ^ Class type variables
tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables
tcdFDs :: [Located (FunDep name)], -- ^ Functional deps
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
......@@ -468,7 +468,7 @@ data HsTyDefn name -- The payload of a type synonym or data type defn
TyData { td_ND :: NewOrData,
td_ctxt :: LHsContext name, -- ^ Context
td_cType :: Maybe CType,
td_kindSig:: Maybe (HsBndrSig (LHsKind name)),
td_kindSig:: Maybe (LHsKind name),
-- ^ Optional kind signature.
--
-- @(Just k)@ for a GADT-style @data@, or @data
......@@ -619,18 +619,18 @@ instance OutputableBndr name
pp_vanilla_decl_head :: OutputableBndr name
=> Located name
-> [LHsTyVarBndr name]
-> LHsTyVarBndrs name
-> HsContext name
-> SDoc
pp_vanilla_decl_head thing tyvars context
= hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars]
= hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
pp_fam_inst_head :: OutputableBndr name
=> Located name
-> HsBndrSig [LHsType name]
-> HsWithBndrs [LHsType name]
-> HsContext name
-> SDoc
pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns
pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
= hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) typats)]
......@@ -660,8 +660,8 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
2 (pp_condecls condecls $$ pp_derivings)
where
pp_sig = case mb_sig of
Nothing -> empty
Just (HsBSig kind _) -> dcolon <+> ppr kind
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_derivings = case derivings of
Nothing -> empty
Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
......@@ -715,7 +715,7 @@ data ConDecl name
, con_explicit :: HsExplicitFlag
-- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
, con_qvars :: [LHsTyVarBndr name]
, con_qvars :: LHsTyVarBndrs name
-- ^ Type variables. Depending on 'con_res' this describes the
-- following entities
--
......@@ -808,8 +808,8 @@ type LFamInstDecl name = Located (FamInstDecl name)
data FamInstDecl name
= FamInstDecl
{ fid_tycon :: Located name
, fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs)
, fid_defn :: HsTyDefn name -- Type or data family instance
, fid_pats :: HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs)
, fid_defn :: HsTyDefn name -- Type or data family instance
, fid_fvs :: NameSet }
deriving( Typeable, Data )
......@@ -1060,10 +1060,10 @@ data RuleDecl name
data RuleBndr name
= RuleBndr (Located name)
| RuleBndrSig (Located name) (HsBndrSig (LHsType name))
| RuleBndrSig (Located name) (HsWithBndrs (LHsType name))
deriving (Data, Typeable)
collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)]
collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
instance OutputableBndr name => Outputable (RuleDecl name) where
......
......@@ -131,8 +131,8 @@ data Pat id
(SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(HsBndrSig (LHsType id))
| SigPatIn (LPat id) -- Pattern with a type signature
(HsWithBndrs (LHsType id)) -- Signature can bind both kind and type vars
| SigPatOut (LPat id) -- Pattern with a type signature
Type
......
......@@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
HsTyVarBndr(..), LHsTyVarBndr,
LHsTyVarBndrs(..),
HsWithBndrs(..),
HsTupleSort(..), HsExplicitFlag(..),
HsContext, LHsContext,
HsQuasiQuote(..),
......@@ -29,15 +31,14 @@ module HsTypes (
ConDeclField(..), pprConDeclFields,
mkHsQTvs, hsQTvBndrs,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames,
hsTyVarName, hsTyVarNames, mkHsWithBndrs,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
splitHsForAllTy, splitLHsForAllTy,
splitLHsInstDeclTy_maybe,
splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType,
splitHsAppTys, mkHsAppTys, mkHsOpTy,
placeHolderBndrs,
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
......@@ -112,6 +113,17 @@ getBangStrictness _ = HsNoBang
This is the syntax for types as seen in type signatures.
Note [HsBSig binder lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a binder (or pattern) decoarated with a type or kind,
\ (x :: a -> a). blah
forall (a :: k -> *) (b :: k). blah
Then we use a LHsBndrSig on the binder, so that the
renamer can decorate it with the variables bound
by the pattern ('a' in the first example, 'k' in the second),
assuming that neither of them is in scope already
See also Note [Kind and type-variable binders] in RnTypes
\begin{code}
type LHsContext name = Located (HsContext name)
......@@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name)
type LHsTyVarBndr name = Located (HsTyVarBndr name)
data HsBndrSig sig
= HsBSig
sig -- The signature; typically a type
([Name], [Name]) -- The *binding* (kind, type) names of
-- this signature
-- See Note [HsBSig binder lists]
data LHsTyVarBndrs name
= HsQTvs { hsq_kvs :: [Name] -- Kind variables
, hsq_tvs :: [LHsTyVarBndr name] -- Type variables
-- See Note [HsForAllTy tyvar binders]
}
deriving( Data, Typeable )
mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
hsQTvBndrs = hsq_tvs
data HsWithBndrs thing
= HsWB { hswb_cts :: thing -- Main payload (type or list of types)
, hswb_kvs :: [Name] -- Kind vars
, hswb_tvs :: [Name] -- Type vars
}
deriving (Data, Typeable)
-- Note [HsBSig binder lists]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Consider a binder (or pattern) decoarated with a type or kind,
-- \ (x :: a -> a). blah
-- forall (a :: k -> *) (b :: k). blah
-- Then we use a LHsBndrSig on the binder, so that the
-- renamer can decorate it with the variables bound
-- by the pattern ('a' in the first example, 'k' in the second),
-- assuming that neither of them is in scope already
-- See also Note [Kind and type-variable binders] in RnTypes
placeHolderBndrs :: [Name]
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderBndrs = panic "placeHolderBndrs"
mkHsWithBndrs :: thing -> HsWithBndrs thing
mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
, hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
data HsTyVarBndr name
= UserTyVar -- No explicit kinding
......@@ -153,17 +165,18 @@ data HsTyVarBndr name
| KindedTyVar
name
(HsBndrSig (LHsKind name)) -- The user-supplied kind signature
(LHsKind name) -- The user-supplied kind signature
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
deriving (Data, Typeable)
data HsType name
= HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way
-- the user wrote it originally, so that the printer can
-- print it as the user wrote it
[LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders]
(LHsTyVarBndrs name)
(LHsContext name)
(LHsType name)
......@@ -252,11 +265,11 @@ After renaming
* Implicit => the *type* variables free in the type
Explicit => the variables the user wrote (renamed)
Note that in neither case do we inclde the kind variables.
In the explicit case, the [HsTyVarBndr] can bring kind variables
into scope: f :: forall (a::k->*) (b::k). a b -> Int
but we do not record them explicitly, similar to the case
for the type variables in a pattern type signature.
The kind variables bound in the hsq_kvs field come both
a) from the kind signatures on the kind vars (eg k1)
b) from the scope of the forall (eg k2)
Example: f :: forall (a::k1) b. T a (b::k2)
Note [Unit tuples]
~~~~~~~~~~~~~~~~~~
......@@ -357,19 +370,19 @@ data ConDeclField name -- Record fields have Haddoc docs on them
mkImplicitHsForAllTy :: LHsContext name -> LHsType name -> HsType name
mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty
mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty
mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
-- Smart constructor for HsForAllTy
mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty
-- mk_forall_ty makes a pure for-all type (no context)
mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty
mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
mk_forall_ty exp tvs ty = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
-- Even if tvs is empty, we still make a HsForAll!
-- In the Implicit case, this signals the place to do implicit quantification
-- In the Explicit case, it prevents implicit quantification
......@@ -396,14 +409,14 @@ hsLTyVarName = hsTyVarName . unLoc
hsTyVarNames :: [HsTyVarBndr name] -> [name]
hsTyVarNames tvs = map hsTyVarName tvs
hsLTyVarNames :: [LHsTyVarBndr name] -> [name]
hsLTyVarNames = map hsLTyVarName
hsLTyVarNames :: LHsTyVarBndrs name -> [name]
hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
hsLTyVarLocName :: LHsTyVarBndr name -> Located name
hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
hsLTyVarLocNames = map hsLTyVarLocName
hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
\end{code}
......@@ -421,31 +434,23 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
-- Add noLocs for inner nodes of the application;
-- they are never used
splitHsInstDeclTy_maybe :: HsType name
-> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
splitHsInstDeclTy_maybe ty
= fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty)
splitLHsInstDeclTy_maybe
:: LHsType name
-> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
-> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
-- Split up an instance decl type, returning the pieces
splitLHsInstDeclTy_maybe inst_ty = do
let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
(cls, tys) <- splitLHsClassTy_maybe ty
return (tvs, cxt, cls, tys)
splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name)
splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty)
splitLHsForAllTy
:: LHsType name
-> ([LHsTyVarBndr name], HsContext name, LHsType name)
-> (LHsTyVarBndrs name, HsContext name, LHsType name)
splitLHsForAllTy poly_ty
= case unLoc poly_ty of
HsParTy ty -> splitLHsForAllTy ty
HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
_ -> ([], [], poly_ty)
_ -> (mkHsQTvs [], [], poly_ty)
-- The type vars should have been computed by now, even if they were implicit
splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
......@@ -494,22 +499,25 @@ instance (OutputableBndr name) => Outputable (HsType name) where
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (Outputable sig) => Outputable (HsBndrSig sig) where
ppr (HsBSig ty _) = ppr ty
instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
ppr qtvs = interppSP (hsQTvBndrs qtvs)
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name) = ppr name
ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll exp tvs cxt
instance (Outputable thing) => Outputable (HsWithBndrs thing) where
ppr (HsWB { hswb_cts = ty }) = ppr ty
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAll exp qtvs cxt
| show_forall = forall_part <+> pprHsContext (unLoc cxt)
| otherwise = pprHsContext (unLoc cxt)
where
show_forall = opt_PprStyle_Debug
|| (not (null tvs) && is_explicit)
|| (not (null (hsQTvBndrs qtvs)) && is_explicit)
is_explicit = case exp of {Explicit -> True; Implicit -> False}
forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext [] = empty
......
......@@ -33,7 +33,7 @@ module HsUtils(
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
......@@ -265,9 +265,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
mkHsBSig :: a -> HsBndrSig a
mkHsBSig x = HsBSig x (placeHolderBndrs, placeHolderBndrs)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
......
......@@ -728,9 +728,9 @@ data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
: { noLoc Nothing }
| '::' kind { LL (Just (mkHsBSig $2)) }
| '::' kind { LL (Just $2) }
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
......@@ -877,7 +877,7 @@ rule_var_list :: { [RuleBndr RdrName] }
rule_var :: { RuleBndr RdrName }
: varid { RuleBndr $1 }
| '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsBSig $4) }
| '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsWithBndrs $4) }
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
......@@ -1113,7 +1113,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { L1 (UserTyVar (unLoc $1)) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (mkHsBSig $4)) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
......