Commit 9b8ba629 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Entirely re-jig the handling of default type-family instances (fixes Trac #9063)

In looking at Trac #9063 I decided to re-design the default
instances for associated type synonyms.  Previously it was all
jolly complicated, to support generality that no one wanted, and
was arguably undesirable.

Specifically

* The default instance for an associated type can have only
  type variables on the LHS.  (Not type patterns.)

* There can be at most one default instances declaration for
  each associated type.

To achieve this I had to do a surprisingly large amount of refactoring
of HsSyn, specifically to parameterise HsDecls.TyFamEqn over the type
of the LHS patterns.

That change in HsDecls has a (trivial) knock-on effect in Haddock, so
this commit does a submodule update too.

The net result is good though.  The code is simpler; the language
specification is simpler.  Happy days.

Trac #9263 and #9264 are thereby fixed as well.
parent f692e8e7
......@@ -396,10 +396,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
, hswb_kvs = kv_names
, hswb_tvs = tv_names }
, tfie_rhs = rhs }))
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
, hswb_kvs = kv_names
, hswb_tvs = tv_names }
, tfe_rhs = rhs }))
= do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ _ ->
......
......@@ -201,13 +201,20 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; unless (null adts')
(failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
$$ (Outputable.ppr adts'))
; at_defs <- mapM cvt_at_def ats'
; returnL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
, tcdATs = fams', tcdATDefs = ats', tcdDocs = []
, tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
, tcdFVs = placeHolderNames }
-- no docs in TH ^^
}
where
cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
-- Very similar to what happens in RdrHsSyn.mkClassDecl
cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
Right def -> return def
Left (_, msg) -> failWith msg
cvtDec (InstanceD ctxt ty decs)
= do { let doc = ptext (sLit "an instance declaration")
......@@ -280,9 +287,9 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM cvtType lhs
; rhs' <- cvtType rhs
; returnL $ TyFamInstEqn { tfie_tycon = tc
, tfie_pats = mkHsWithBndrs lhs'
, tfie_rhs = rhs' } }
; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsWithBndrs lhs'
, tfe_rhs = rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......
......@@ -29,7 +29,7 @@ module HsDecls (
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
TyFamInstEqn(..), LTyFamInstEqn,
TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
......@@ -472,7 +472,7 @@ data TyClDecl name
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie
tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults
tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: NameSet
}
......@@ -573,7 +573,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: OutputableBndr name
=> TyFamInstDecl name -> Located name
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(L _ (TyFamInstEqn { tfie_tycon = ln })) })
(L _ (TyFamEqn { tfe_tycon = ln })) })
= ln
tyClDeclLName :: TyClDecl name -> Located name
......@@ -632,7 +632,7 @@ instance OutputableBndr name
| otherwise -- Laid out
= vcat [ top_matter <+> ptext (sLit "where")
, nest 2 $ pprDeclList (map ppr ats ++
map ppr at_defs ++
map ppr_fam_deflt_eqn at_defs ++
pprLHsBindsForUser methods sigs) ]
where
top_matter = ptext (sLit "class")
......@@ -657,7 +657,7 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where
ClosedTypeFamily eqns -> ( ptext (sLit "where")
, if null eqns
then ptext (sLit "..")
else vcat $ map ppr eqns )
else vcat $ map ppr_fam_inst_eqn eqns )
_ -> (empty, empty)
pprFlavour :: FamilyInfo name -> SDoc
......@@ -678,7 +678,7 @@ pp_vanilla_decl_head thing tyvars context
pp_fam_inst_lhs :: OutputableBndr name
=> Located name
-> HsWithBndrs [LHsType name]
-> HsTyPats name
-> HsContext name
-> SDoc
pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
......@@ -686,12 +686,13 @@ pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patt
, hsep (map (pprParendHsType.unLoc) typats)]
pprTyClDeclFlavour :: TyClDecl a -> SDoc
pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family")
pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type")
pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
= ppr nd
pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class")
pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type")
pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
\end{code}
%************************************************************************
......@@ -893,25 +894,49 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
%* *
%************************************************************************
Note [Type family instance declarations in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The data type TyFamEqn represents one equation of a type family instance.
It is parameterised over its tfe_pats field:
* An ordinary type family instance declaration looks like this in source Haskell
type instance T [a] Int = a -> a
(or something similar for a closed family)
It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
* On the other hand, the *default instance* of an associated type looksl like
this in source Haskell
class C a where
type T a b
type T a b = a -> b -- The default instance
It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field.
\begin{code}
----------------- Type synonym family instances -------------
type LTyFamInstEqn name = Located (TyFamInstEqn name)
type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
type LTyFamInstEqn name = Located (TyFamInstEqn name)
-- | One equation in a type family instance declaration
data TyFamInstEqn name
= TyFamInstEqn
{ tfie_tycon :: Located name
, tfie_pats :: HsWithBndrs [LHsType name]
type HsTyPats name = HsWithBndrs [LHsType name]
-- ^ Type patterns (with kind and type bndrs)
-- See Note [Family instance declaration binders]
, tfie_rhs :: LHsType name }
type TyFamInstEqn name = TyFamEqn name (HsTyPats name)
type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name)
-- See Note [Type family instance declarations in HsSyn]
-- | One equation in a type family instance declaration
-- See Note [Type family instance declarations in HsSyn]
data TyFamEqn name pats
= TyFamEqn
{ tfe_tycon :: Located name
, tfe_pats :: pats
, tfe_rhs :: LHsType name }
deriving( Typeable, Data )
type LTyFamInstDecl name = Located (TyFamInstDecl name)
data TyFamInstDecl name
data TyFamInstDecl name
= TyFamInstDecl
{ tfid_eqn :: LTyFamInstEqn name
{ tfid_eqn :: LTyFamInstEqn name
, tfid_fvs :: NameSet }
deriving( Typeable, Data )
......@@ -921,11 +946,9 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name)
data DataFamInstDecl name
= DataFamInstDecl
{ dfid_tycon :: Located name
, dfid_pats :: HsWithBndrs [LHsType name] -- lhs
-- ^ Type patterns (with kind and type bndrs)
-- See Note [Family instance declaration binders]
, dfid_defn :: HsDataDefn name -- rhs
, dfid_fvs :: NameSet } -- free vars for dependency analysis
, dfid_pats :: HsTyPats name -- LHS
, dfid_defn :: HsDataDefn name -- RHS
, dfid_fvs :: NameSet } -- Rree vars for dependency analysis
deriving( Typeable, Data )
......@@ -937,10 +960,10 @@ data ClsInstDecl name
{ cid_poly_ty :: LHsType name -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
, cid_binds :: LHsBinds name
, cid_sigs :: [LSig name] -- User-supplied pragmatic info
, cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances
, cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
, cid_binds :: LHsBinds name -- Class methods
, cid_sigs :: [LSig name] -- User-supplied pragmatic info
, cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances
, cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
, cid_overlap_mode :: Maybe OverlapMode
}
deriving (Data, Typeable)
......@@ -984,17 +1007,23 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
= ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = ptext (sLit "instance")
ppr_instance_keyword NotTopLevel = empty
instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
ppr (TyFamInstEqn { tfie_tycon = tycon
, tfie_pats = pats
, tfie_rhs = rhs })
= (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc
ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
, tfe_pats = pats
, tfe_rhs = rhs }))
= pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs
ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc
ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tvs
, tfe_rhs = rhs }))
= pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs
instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
ppr = pprDataFamInstDecl TopLevel
......
......@@ -168,9 +168,10 @@ data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
data IfaceAT = IfaceAT
IfaceDecl -- The associated type declaration
[IfaceAxBranch] -- Default associated type instances, if any
data IfaceAT = IfaceAT -- See Class.ClassATItem
IfaceDecl -- The associated type declaration
(Maybe IfaceType) -- Default associated type instance, if any
-- This is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
......@@ -839,12 +840,12 @@ instance Outputable IfaceAT where
ppr = pprIfaceAT showAll
pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
pprIfaceAT ss (IfaceAT d defs)
pprIfaceAT ss (IfaceAT d mb_def)
= vcat [ pprIfaceDecl ss d
, ppUnless (null defs) $ nest 2 $
ptext (sLit "Defaults:") <+> vcat (map (pprAxBranch pp_tc) defs) ]
where
pp_tc = ppr (ifName d)
, case mb_def of
Nothing -> empty
Just rhs -> nest 2 $
ptext (sLit "Default:") <+> ppr rhs ]
instance Outputable IfaceTyConParent where
ppr p = pprIfaceTyConParent p
......@@ -1174,9 +1175,11 @@ freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
freeNamesIfAT :: IfaceAT -> NameSet
freeNamesIfAT (IfaceAT decl defs)
freeNamesIfAT (IfaceAT decl mb_def)
= freeNamesIfDecl decl &&&
fnList freeNamesIfAxBranch defs
case mb_def of
Nothing -> emptyNameSet
Just rhs -> freeNamesIfType rhs
freeNamesIfClsSig :: IfaceClassOp -> NameSet
freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
......
......@@ -1476,7 +1476,7 @@ checkList (check:checks) = do recompile <- check
\begin{code}
tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon
tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
tyThingToIfaceDecl (AConLike cl) = case cl of
RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
......@@ -1568,48 +1568,52 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
-- See Note [CoAxBranch type variables] in CoAxiom
-----------------
tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl
tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
-- We *do* tidy TyCons, because they are not (and cannot
-- conveniently be) built in tidy form
-- The returned TidyEnv is the one after tidying the tyConTyVars
tyConToIfaceDecl env tycon
| Just clas <- tyConClass_maybe tycon
= classToIfaceDecl env clas
| Just syn_rhs <- synTyConRhs_maybe tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) }
= ( tc_env1
, IfaceSyn { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) })
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
ifParent = parent }
= ( tc_env1
, IfaceData { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
ifParent = parent })
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
= (env, IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon })
| otherwise
| otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
-- For pretty printing purposes only.
= IfaceData { ifName = getOccName tycon,
ifCType = Nothing,
ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [],
ifRec = boolToRecFlag False,
ifGadtSyntax = False,
ifPromotable = False,
ifParent = IfNoParent }
= ( env
, IfaceData { ifName = getOccName tycon,
ifCType = Nothing,
ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [],
ifRec = boolToRecFlag False,
ifGadtSyntax = False,
ifPromotable = False,
ifParent = IfNoParent })
where
(tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
if_tc_tyvars = toIfaceTvBndrs tc_tyvars
......@@ -1680,17 +1684,18 @@ toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env c
toIfaceBang _ HsStrict = IfStrict
toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang"
classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getOccName (classTyCon clas),
ifTyVars = toIfaceTvBndrs clas_tyvars',
ifRoles = tyConRoles (classTyCon clas),
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getFS (classMinimalDef clas),
ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
= ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getOccName (classTyCon clas),
ifTyVars = toIfaceTvBndrs clas_tyvars',
ifRoles = tyConRoles (classTyCon clas),
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getFS (classMinimalDef clas),
ifRec = boolToRecFlag (isRecursiveTyCon tycon) })
where
(clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig clas
......@@ -1699,8 +1704,10 @@ classToIfaceDecl env clas
(env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (tc, defs)
= IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' tc) defs)
toIfaceAT (ATI tc def)
= IfaceAT if_decl (fmap (tidyToIfaceType env2) def)
where
(env2, if_decl) = tyConToIfaceDecl env1 tc
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
......
......@@ -544,13 +544,18 @@ tc_iface_decl _parent ignore_prags
-- it mentions unless it's necessary to do so
; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl defs_decls)
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls)
mb_def <- case if_def of
Nothing -> return Nothing
Just def -> forkM (mk_at_doc tc) $
extendIfaceTyVarEnv (tyConTyVars tc) $
do { tc_def <- tcIfaceType def
; return (Just tc_def) }
-- Must be done lazily in case the RHS of the defaults mention
-- the type constructor being defined here
-- e.g. type AT a; type AT b = AT [b] Trac #8002
return (tc, defs)
return (ATI tc mb_def)
mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc
......
......@@ -34,6 +34,7 @@ module RdrHsSyn (
mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
mkSimpleConDecl,
mkDeprecatedGadtRecordDecl,
mkATDefault,
-- Bunch of functions in the parser monad for
-- checking and constructing values
......@@ -73,7 +74,7 @@ import TysWiredIn ( unitTyCon, unitDataCon )
import ForeignCall
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
import PrelNames ( forall_tv_RDR )
import PrelNames ( forall_tv_RDR, allNameStrings )
import DynFlags
import SrcLoc
import OrdList ( OrdList, fromOL )
......@@ -124,16 +125,31 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl RdrName)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls)
= do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls)
cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars (ptext (sLit "class")) whereDots
cls tparams -- Only type vars allowed
; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
; at_defs <- mapM (eitherToP . mkATDefault) at_insts
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs,
tcdFVs = placeHolderNames })) }
mkATDefault :: LTyFamInstDecl RdrName
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
-- Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration
-- We parse things as the former and use this function to convert to the latter
--
-- We use the Either monad because this also called
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
| TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
= do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
; return (L loc (TyFamEqn { tfe_tycon = tc
, tfe_pats = tvs
, tfe_rhs = rhs })) }
mkTyData :: SrcSpan
-> NewOrData
-> Maybe CType
......@@ -144,7 +160,7 @@ mkTyData :: SrcSpan
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdDataDefn = defn,
......@@ -172,7 +188,7 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl RdrName)
mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars (ptext (sLit "type")) equalsDots tc tparams
; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
, tcdRhs = rhs, tcdFVs = placeHolderNames })) }
......@@ -181,9 +197,9 @@ mkTyFamInstEqn :: LHsType RdrName
-> P (TyFamInstEqn RdrName)
mkTyFamInstEqn lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; return (TyFamInstEqn { tfie_tycon = tc
, tfie_pats = mkHsWithBndrs tparams
, tfie_rhs = rhs }) }
; return (TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsWithBndrs tparams
, tfe_rhs = rhs }) }
mkDataFamInst :: SrcSpan
-> NewOrData
......@@ -214,7 +230,7 @@ mkFamDecl :: SrcSpan
-> P (LTyClDecl RdrName)
mkFamDecl loc info lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc
, fdTyVars = tyvars, fdKindSig = ksig }))) }
where
......@@ -502,26 +518,42 @@ we can bring x,y into scope. So:
* For RecCon we do not
\begin{code}
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Same as checkTyVars, but in the P monad
checkTyVarsP pp_what equals_or_where tc tparms
= eitherToP $ checkTyVars pp_what equals_or_where tc tparms
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
-> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
-- Convert.hs
checkTyVars pp_what equals_or_where tc 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 k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk t@(L l _)
= parseErrorSDoc l $
vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
, ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
, vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
, nest 2 (pp_what <+> ppr tc <+> ptext (sLit "a b c")
<+> equals_or_where) ] ]
chk t@(L loc _)
= Left (loc,
vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
, ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
, vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
, nest 2 (pp_what <+> ppr tc
<+> hsep (map text (takeList tparms allNameStrings))
<+> equals_or_where) ] ])
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
whereDots = ptext (sLit "where ...")
equalsDots = ptext (sLit "= ...")
......
......@@ -465,7 +465,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
; ((ats', adts', other_sigs'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
; return ( (ats', adts', other_sigs')
......@@ -564,14 +564,29 @@ rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn RdrName
-> RnM (TyFamInstEqn Name, FreeVars)
rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon
, tfie_pats = HsWB { hswb_cts = pats }
, tfie_rhs = rhs })
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = HsWB { hswb_cts = pats }
, tfe_rhs = rhs })
= do { (tycon', pats', rhs', fvs) <-
rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
; return (TyFamInstEqn { tfie_tycon = tycon'
, tfie_pats = pats'
, tfie_rhs = rhs' }, fvs) }
; return (TyFamEqn { tfe_tycon = tycon'
, tfe_pats = pats'
, tfe_rhs = rhs' }, fvs) }
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn RdrName
-> RnM (TyFamDefltEqn Name, FreeVars)
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tyvars
, tfe_rhs = rhs })
= bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (TyFamEqn { tfe_tycon = tycon'
, tfe_pats = tyvars'
, tfe_rhs = rhs' }, fvs) }
where
ctx = TyFamilyCtx tycon
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl RdrName
......@@ -590,7 +605,7 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
Renaming of the associated types in instances.
\begin{code}
-- rename associated type family decl in class
-- Rename associated type family decl in class
rnATDecls :: Name -- Class
-> [LFamilyDecl RdrName]
-> RnM ([LFamilyDecl Name], FreeVars)
......@@ -941,7 +956,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
do { (rhs', fvs) <- rnTySyn doc rhs
; return ((tyvars', rhs'), fvs) }
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdRhs = rhs', tcdFVs = fvs }, fvs) }
, tcdRhs = rhs', tcdFVs = fvs }, fvs) }
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
......@@ -966,20 +981,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- kind signatures on the tyvars
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
<- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds fds
-- The fundeps have no free variables