+
+-- Rename associated data type declarations
+--
+rnATs :: [LHsTyVarBndr Name] -> [LTyClDecl RdrName]
+ -> RnM ([LTyClDecl Name], FreeVars)
+rnATs classLTyVars ats
+ = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ -- The parser won't accept anything, but a data declarations
+ rn_at (tydecl@TyData {tcdCtxt = L ctxtL ctxt, tcdLName = tycon,
+ tcdTyPats = Just typats, tcdCons = condecls,
+ tcdDerivs = derivs}) =
+ do { checkM (null ctxt ) $ addErr atNoCtxt -- no context
+ ; checkM (null condecls) $ addErr atNoCons -- no constructors
+ -- check and collect type parameters
+ ; let (idxParms, excessParms) = splitAt (length classLTyVars) typats
+ ; zipWithM_ cmpTyVar idxParms classLTyVars
+ ; excessTyVars <- liftM catMaybes $ mappM chkTyVar excessParms
+ -- bind excess parameters
+ ; bindTyVarsRn data_doc excessTyVars $ \ excessTyVars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = L ctxtL [],
+ tcdLName = tycon',
+ tcdTyVars = classLTyVars ++ excessTyVars',
+ tcdTyPats = Nothing, tcdKindSig = Nothing,
+ tcdCons = [], tcdDerivs = derivs'},
+ delFVs (map hsLTyVarName (classLTyVars ++ excessTyVars')) $
+ deriv_fvs) } }
+ where
+ -- Check that the name space is correct!
+ cmpTyVar (L l ty@(HsTyVar tv)) classTV = -- just a type variable
+ checkM (rdrNameOcc tv == nameOccName classTVName) $
+ mustMatchErr l ty classTVName
+ where
+ classTVName = hsLTyVarName classTV
+ cmpTyVar (L l ty@(HsKindSig (L _ (HsTyVar tv)) k)) _ | isRdrTyVar tv =
+ noKindSigErr l tv -- additional kind sig not allowed at class parms
+ cmpTyVar (L l otherTy) _ =
+ tyVarExpectedErr l -- parameter must be a type variable
+
+ -- Check that the name space is correct!
+ chkTyVar (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv = return $ Just (L l (KindedTyVar tv k))
+ chkTyVar (L l (HsTyVar tv))
+ | isRdrTyVar tv = return $ Just (L l (UserTyVar tv))
+ chkTyVar (L l otherTy) = tyVarExpectedErr l >> return Nothing
+ -- drop parameter; we stop after renaming anyways
+
+ rn_derivs Nothing = returnM (Nothing, emptyFVs)
+ rn_derivs (Just ds) = do
+ ds' <- rnLHsTypes data_doc ds
+ returnM (Just ds', extractHsTyNames_s ds')
+
+ atNoCtxt = text "Associated data type declarations cannot have a context"
+ atNoCons = text "Associated data type declarations cannot have any constructors"
+ data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+noKindSigErr l ty =
+ addErrAt l $
+ sep [ptext SLIT("No kind signature allowed at copies of class parameters:"),
+ nest 2 $ ppr ty]
+
+mustMatchErr l ty classTV =
+ addErrAt l $
+ sep [ptext SLIT("Type variable"), quotes (ppr ty),
+ ptext SLIT("must match corresponding class parameter"),
+ quotes (ppr classTV)]
+
+tyVarExpectedErr l =
+ addErrAt l (ptext SLIT("Type found where type variable expected"))