-
--- 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"))