X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=6053098c6fb645d42928e800ce7d88a3a2ac3d36;hp=023a6cfe3ae836659fd835da6902309799b00ee1;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=658372b8c24dee8c37a729c9a1500a3e3b9735d9 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 023a6cf..6053098 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,9 +15,8 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, - elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..), - isLocalGRE ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, + globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) @@ -42,8 +41,8 @@ import Outputable import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) -import Maybe ( isNothing, catMaybes ) -import Monad ( liftM ) +import Maybe ( isNothing, isJust ) +import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) \end{code} @@ -111,10 +110,8 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; let { - rn_at_decls = concat - [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ; rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls ++ rn_at_decls, + hs_tyclds = rn_tycl_decls, hs_instds = rn_inst_decls, hs_fixds = rn_fix_decls, hs_depds = [], @@ -282,12 +279,11 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the declarations are for the right class let - at_doc = text "In the associated types in an instance declaration" + at_doc = text "In the associated types of an instance declaration" at_names = map (head . tyClDeclNames . unLoc) ats - (_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty) in checkDupNames at_doc at_names `thenM_` - rnATDefs rdrCtxt ats `thenM` \ (ats', at_fvs) -> + rnATInsts ats `thenM` \ (ats', at_fvs) -> -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -333,20 +329,28 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- to remove the context). \end{code} -Renaming of the associated data definitions requires adding the instance -context, as the rhs of an AT declaration may use ATs from classes in the -context. +Renaming of the associated types in instances. + +* We raise an error if we encounter a kind signature in an instance. \begin{code} -rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] - -> RnM ([LTyClDecl Name], FreeVars) -rnATDefs ctxt atDecls = - mapFvRn (wrapLocFstM addCtxtAndRename) atDecls +rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATInsts atDecls = + mapFvRn (wrapLocFstM rnATInst) atDecls where - -- The parser won't accept anything, but a data declaration - addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = - rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)}) - -- The source loc is somewhat half hearted... -=chak + rnATInst tydecl@TyFunction {} = + do + addErr noKindSig + rnTyClDecl tydecl + rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl + rnATInst tydecl@TyData {} = + do + checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig + rnTyClDecl tydecl + rnATInst _ = + panic "RnSource.rnATInsts: not a type declaration" + +noKindSig = text "Instances cannot have kind signatures" \end{code} For the method bindings in class and instance decls, we extend the @@ -491,14 +495,19 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, emptyFVs) -rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdTyPats = typatsMaybe, - tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs}) - | is_vanilla -- Normal Haskell data type decl +rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, + tcdLName = tycon, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdCons = condecls, + tcdKindSig = sig, tcdDerivs = derivs}) + | isKindSigDecl tydecl -- kind signature of indexed type + = rnTySig tydecl bindTyVarsRn + | is_vanilla -- Normal Haskell data type decl = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs @@ -511,11 +520,17 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs) } + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } - | otherwise -- GADT + | otherwise -- GADT = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) ; tyvars' <- bindTyVarsRn data_doc tyvars (\ tyvars' -> return tyvars') @@ -529,8 +544,12 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } - + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } where is_vanilla = case condecls of -- Yuk [] -> True @@ -549,14 +568,26 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> returnM (Just ds', extractHsTyNames_s ds') - -rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) - = lookupLocatedTopBndrRn name `thenM` \ name' -> - bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> - returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', - tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') fvs) + +rnTyClDecl (tydecl@TyFunction {}) = + rnTySig tydecl bindTyVarsRn + +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) + = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + do { name' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name + ; typats' <- rnTyPats syn_doc typatsMaybe + ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', + tcdTyPats = typats', tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') $ + fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc name') -- type instance => use + else emptyFVs)) + } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -569,7 +600,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, bindTyVarsRn cls_doc tyvars ( \ tyvars' -> rnContext cls_doc context `thenM` \ context' -> rnFds cls_doc fds `thenM` \ fds' -> - rnATs tyvars' ats `thenM` \ (ats', ats_fvs) -> + rnATs ats `thenM` \ (ats', ats_fvs) -> renameSigs okClsDclSig sigs `thenM` \ sigs' -> returnM (tyvars', context', fds', (ats', ats_fvs), sigs') ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') -> @@ -639,7 +670,7 @@ badGadtStupidTheta tycon %********************************************************* \begin{code} --- Although, we are processing type patterns here, all type variables should +-- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) -- @@ -712,6 +743,103 @@ rnField doc (name, ty) rnLHsType doc ty `thenM` \ new_ty -> returnM (new_name, new_ty) +-- Rename kind signatures (signatures of indexed data types/newtypes and +-- signatures of type functions) +-- +-- * This function is parametrised by the routine handling the index +-- variables. On the toplevel, these are defining occurences, whereas they +-- are usage occurences for associated types. +-- +rnTySig :: TyClDecl RdrName + -> (SDoc -> [LHsTyVarBndr RdrName] -> + ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> + RnM (TyClDecl Name, FreeVars)) + -> RnM (TyClDecl Name, FreeVars) + +rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, + tcdTyVars = tyvars, tcdTyPats = mb_typats, + tcdCons = condecls, tcdKindSig = sig, + tcdDerivs = derivs}) + bindIdxVars = + ASSERT( null condecls ) -- won't have constructors + ASSERT( isNothing mb_typats ) -- won't have type patterns + ASSERT( isNothing derivs ) -- won't have deriving + ASSERT( isJust sig ) -- will have kind signature + do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1 + ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do { + ; tycon' <- lookupLocatedTopBndrRn tycon + ; context' <- rnContext (ksig_doc tycon) context + ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context', + tcdLName = tycon', tcdTyVars = tyvars', + tcdTyPats = Nothing, tcdKindSig = sig, + tcdCons = [], tcdDerivs = Nothing}, + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context') + } } + where + +rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, + tcdKind = sig}) + bindIdxVars = + do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1 + ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do { + ; tycon' <- lookupLocatedTopBndrRn tycon + ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars', + tcdIso = tcdIso tydecl, tcdKind = sig}, + emptyFVs) + } } + +ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon) +needOneIdx = text "Kind signature requires at least one type index" + +-- Rename associated type declarations (in classes) +-- +-- * This can be kind signatures and (default) type function equations. +-- +rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATs ats = mapFvRn (wrapLocFstM rn_at) ats + where + rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars + rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars + rn_at (tydecl@TySynonym {}) = + do + checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns + rnTyClDecl tydecl + rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" + + lookupIdxVars _ tyvars cont = + do { checkForDups tyvars; + ; tyvars' <- mappM lookupIdxVar tyvars + ; cont tyvars' + } + -- Type index variables must be class parameters, which are the only + -- type variables in scope at this point. + lookupIdxVar (L l tyvar) = + do + name' <- lookupOccRn (hsTyVarName tyvar) + return $ L l (replaceTyVarName tyvar name') + + -- Type variable may only occur once. + -- + checkForDups [] = return () + checkForDups (L loc tv:ltvs) = + do { setSrcSpan loc $ + when (hsTyVarName tv `ltvElem` ltvs) $ + addErr (repeatedTyVar tv) + ; checkForDups ltvs + } + + rdrName `ltvElem` [] = False + rdrName `ltvElem` (L _ tv:ltvs) + | rdrName == hsTyVarName tv = True + | otherwise = rdrName `ltvElem` ltvs + +noPatterns = text "Default definition for an associated synonym cannot have" + <+> text "type pattern" + +repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> + quotes (ppr tv) + -- This data decl will parse OK -- data T = a Int -- treating "a" as the constructor. @@ -748,77 +876,6 @@ rnFds doc fds rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar - --- 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")) \end{code}