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

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
......
This diff is collapsed.
......@@ -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 [] }
......
......@@ -128,14 +128,14 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
{ TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
, tcdTyVars = map toHsTvBndr $3
, tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
, tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc []
, td_kindSig = Nothing
, td_cons = $6, td_derivs = Nothing } } }
| '%newtype' q_tc_name tv_bndrs trep ';'
{ let tc_rdr = ifaceExtRdrName $2 in
TyDecl { tcdLName = noLoc tc_rdr
, tcdTyVars = map toHsTvBndr $3
, tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
, tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
, td_kindSig = Nothing
, td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
......@@ -377,16 +377,16 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
where
bsig = mkHsBSig (toHsKind k)
bsig = toHsKind k
ifaceExtRdrName :: Name -> RdrName
ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
add_forall tv (L _ (HsForAllTy exp tvs cxt t))
= noLoc $ HsForAllTy exp (tv:tvs) cxt t
= noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t
add_forall tv t
= noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
= noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
......
......@@ -122,7 +122,7 @@ mkTyData :: SrcSpan
-> NewOrData
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (HsBndrSig (LHsKind RdrName))
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
......@@ -138,20 +138,20 @@ mkFamInstData :: SrcSpan
-> NewOrData
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (HsBndrSig (LHsKind RdrName))
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LFamInstDecl RdrName)
mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
, fid_defn = defn, fid_fvs = placeHolderNames })) }
mkDataDefn :: NewOrData
-> Maybe CType
-> Maybe (LHsContext RdrName)
-> Maybe (HsBndrSig (LHsKind RdrName))
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (HsTyDefn RdrName)
......@@ -181,14 +181,14 @@ mkFamInstSynonym :: SrcSpan
-> P (LFamInstDecl RdrName)
mkFamInstSynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
, fid_defn = TySynonym { td_synRhs = rhs }
, fid_fvs = placeHolderNames })) }
mkTyFamily :: SrcSpan
-> FamilyFlavour
-> LHsType RdrName -- LHS
-> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
-> Maybe (LHsKind RdrName) -- Optional kind signature
-> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
......@@ -367,7 +367,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
; return (L loc (ConDecl { con_old_rec = True
, con_name = data_con
, con_explicit = Implicit
, con_qvars = []
, con_qvars = mkHsQTvs []
, con_cxt = noLoc []
, con_details = RecCon flds
, con_res = ResTyGADT res_ty
......@@ -381,7 +381,7 @@ mkSimpleConDecl name qvars cxt details
= ConDecl { con_old_rec = False
, con_name = name
, con_explicit = Explicit
, con_qvars = qvars
, con_qvars = mkHsQTvs qvars
, con_cxt = cxt
, con_details = details
, con_res = ResTyH98
......@@ -444,17 +444,18 @@ we can bring x,y into scope. So:
* For RecCon we do not
\begin{code}
checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
checkTyVars tycl_hdr tparms = mapM chk tparms
checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv (mkHsBSig k)))
| isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk t@(L l _)
......@@ -579,7 +580,7 @@ checkAPat dynflags loc e0 = case e0 of
let t' = case t of
L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
other -> other
return (SigPatIn e (mkHsBSig t'))
return (SigPatIn e (mkHsWithBndrs t'))
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
......
......@@ -539,7 +539,7 @@ mkSigTvFn sigs
= \n -> lookupNameEnv env n `orElse` []
where
env :: NameEnv [Name]
env = mkNameEnv [ (name, map hsLTyVarName ltvs)
env = mkNameEnv [ (name, hsLTyVarNames ltvs)
| L _ (TypeSig names
(L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
, (L _ name) <- names]
......
......@@ -36,7 +36,7 @@ module RnEnv (
bindLocatedLocalsFV, bindLocatedLocalsRn,
extendTyVarEnvFVRn,
checkDupRdrNames, checkDupAndShadowedRdrNames,
checkDupRdrNames, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
......@@ -1185,7 +1185,8 @@ bindLocatedLocalsRn :: [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
= do { checkDupAndShadowedRdrNames rdr_names_w_loc
= do { checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
-- Make fresh Names and extend the environment
; names <- newLocalBndrsRn rdr_names_w_loc
......@@ -1243,11 +1244,10 @@ checkDupNames names
-- See Note [Binders in Template Haskell] in Convert
---------------------
checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
checkDupAndShadowedRdrNames loc_rdr_names
= do { checkDupRdrNames loc_rdr_names
; envs <- getRdrEnvs
; checkShadowedOccs envs loc_occs }
checkShadowedRdrNames :: [Located RdrName] -> RnM ()
checkShadowedRdrNames loc_rdr_names
= do { envs <- getRdrEnvs
; checkShadowedOccs envs loc_occs }
where
loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
......@@ -1645,8 +1645,10 @@ data HsDocContext
| SpliceTypeCtx (LHsType RdrName)
| ClassInstanceCtx
| VectDeclCtx (Located RdrName)
| GenericCtx SDoc -- Maybe we want to use this more!
docOfHsDocContext :: HsDocContext -> SDoc
docOfHsDocContext (GenericCtx doc) = doc
docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
docOfHsDocContext PatCtx = text "In a pattern type-signature"
docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
......@@ -1666,5 +1668,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
\end{code}
......@@ -162,9 +162,9 @@ matchNameMaker ctxt = LamMk report_unused
StmtCtxt GhciStmt -> False
_ -> True
rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name))
rnHsSigCps sig
= CpsRn (rnHsBndrSig True PatCtx sig)
= CpsRn (rnHsBndrSig PatCtx sig)
newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
......
......@@ -43,7 +43,6 @@ import Outputable
import Bag
import BasicTypes ( RuleName )
import FastString
import Util ( filterOut )
import SrcLoc
import DynFlags
import HscTypes ( HscEnv, hsc_dflags )
......@@ -485,7 +484,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
-- to remove the context).
rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
, fid_pats = HsWB { hswb_cts = pats }
, fid_defn = defn })
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
......@@ -494,8 +495,9 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names)
; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names)
; rdr_env <- getLocalRdrEnv
; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
-- All the free vars of the family patterns
-- with a sensible binding location
; ((pats', defn'), fvs)
......@@ -516,8 +518,8 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
; let all_fvs = fvs `addOneFV` unLoc tycon'
; return ( FamInstDecl { fid_tycon = tycon'
, fid_pats = HsBSig pats' (kv_names, tv_names)
, fid_defn = defn', fid_fvs = all_fvs }
, fid_pats = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
, fid_defn = defn', fid_fvs = all_fvs }
, all_fvs ) }
-- type instance => use, hence addOneFV
\end{code}
......@@ -543,13 +545,13 @@ For the method bindings in class and instance decls, we extend the
type variable environment iff -fglasgow-exts
\begin{code}
extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (Bag (LHsBind Name), FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
= do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
; if scoped_tvs then
extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
else
thing_inside }
\end{code}
......@@ -584,7 +586,8 @@ standaloneDerivErr
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= do { let rdr_names_w_loc = map get_var vars
; checkDupAndShadowedRdrNames rdr_names_w_loc
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
; bindHsRuleVars rule_name vars names $ \ vars' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
......@@ -610,7 +613,7 @@ bindHsRuleVars rule_name vars names thing_inside
thing_inside (RuleBndr (L loc n) : vars')
go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
= rnHsBndrSig True doc bsig $ \ bsig' ->
= rnHsBndrSig doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (RuleBndrSig (L loc n) bsig' : vars')
......@@ -841,38 +844,40 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
-- in a class decl
rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
, tcdFlavour = flav, tcdKindSig = kind })
= do { let tv_rdr_names = hsLTyVarLocNames tyvars
; checkDupRdrNames tv_rdr_names -- Check for duplicated bindings
; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names
; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' ->
= bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFlavour = flav, tcdKindSig = kind' }
, fv_kind) } }
, fv_kind ) }
where
fmly_doc = TyFamilyCtx tycon
kvs = extractRdrKindSigVars kind
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' ->
; let kvs = extractTyDefnKindVars defn
; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
do { (defn', fvs) <- rnTyDefn tycon defn
; return ((tyvars', defn'), fvs) }
; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
tcdDocs = docs})
rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
tcdDocs = docs})
= do { lcls' <- lookupLocatedTopBndrRn lcls
; let cls' = unLoc lcls'
kvs = [] -- No scoped kind vars except those in
-- kind signatures on the tyvars
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
<- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
<- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds (docOfHsDocContext cls_doc) fds
......@@ -1042,21 +1047,6 @@ is jolly confusing. See Trac #4875
%*********************************************************
\begin{code}
---------------
mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name]
mkTyVarBndrNames Nothing tv_rdr_names
= newLocalBndrsRn tv_rdr_names
mkTyVarBndrNames (Just _) tv_rdr_names
= do { rdr_env <- getLocalRdrEnv
; let mk_tv_name :: Located RdrName -> RnM Name
-- Use the same Name as the parent class decl
mk_tv_name (L l tv_rdr)
= case lookupLocalRdrEnv rdr_env tv_rdr of
Just n -> return n