X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=606139b116b62824e4ed3a05f2fb4532d9d252cb;hb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1;hp=ae994d05d0031ad2ccf09fe094db1a221a6ecc7c;hpb=8dabe4de7f321fb25899356a9198ac7aff57a9e9;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index ae994d0..606139b 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,8 +15,9 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, - GlobalRdrElt(..), isLocalGRE ) +import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, + elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..), + isLocalGRE ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) @@ -41,7 +42,8 @@ import Outputable import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) -import Maybe ( isNothing ) +import Maybe ( isNothing, isJust ) +import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) \end{code} @@ -270,10 +272,20 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} -rnSrcInstDecl (InstDecl inst_ty mbinds uprags) +rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> + -- Rename the associated types + -- The typechecker (not the renamer) checks that all + -- the declarations are for the right class + let + at_doc = text "In the associated types of an instance declaration" + at_names = map (head . tyClDeclNames . unLoc) ats + in + checkDupNames at_doc at_names `thenM_` + rnATInsts ats `thenM` \ (ats', at_fvs) -> + -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class @@ -302,9 +314,44 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) in bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> - returnM (InstDecl inst_ty' mbinds' uprags', - meth_fvs `plusFV` hsSigsFVs uprags' + returnM (InstDecl inst_ty' mbinds' uprags' ats', + meth_fvs `plusFV` at_fvs + `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). +\end{code} + +Renaming of the associated types in instances. + +* We raise an error if we encounter a kind signature in an instance. + +\begin{code} +rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATInsts atDecls = + mapFvRn (wrapLocFstM rnATInst) atDecls + where + 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 @@ -449,28 +496,34 @@ 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, 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 ; context' <- rnContext data_doc context + ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', - tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', - tcdDerivs = derivs'}, + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', + tcdLName = tycon', tcdTyVars = tyvars', + tcdTyPats = typats', tcdKindSig = Nothing, + tcdCons = condecls', tcdDerivs = derivs'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` - plusFVs (map conDeclFVs condecls') `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } - | otherwise -- GADT - = do { tycon' <- lookupLocatedTopBndrRn tycon + | otherwise -- GADT + = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now + do { tycon' <- lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) ; tyvars' <- bindTyVarsRn data_doc tyvars (\ tyvars' -> return tyvars') @@ -480,9 +533,10 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, ; (derivs', deriv_fvs) <- rn_derivs derivs ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig, - tcdDerivs = derivs'}, + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + tcdLName = tycon', tcdTyVars = tyvars', + tcdTyPats = Nothing, tcdKindSig = sig, + tcdCons = condecls', tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } where @@ -491,6 +545,10 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, L _ (ConDecl { con_res = ResTyH98 }) : _ -> True other -> False + none Nothing = True + none (Just []) = True + none _ = False + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) con_names = map con_names_helper condecls @@ -499,29 +557,41 @@ 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 (TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) + = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + do { name' <- 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) } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds}) + tcdMeths = mbinds, tcdATs = ats}) = lookupLocatedTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures bindTyVarsRn cls_doc tyvars ( \ tyvars' -> rnContext cls_doc context `thenM` \ context' -> rnFds cls_doc fds `thenM` \ fds' -> + rnATs ats `thenM` \ (ats', ats_fvs) -> renameSigs okClsDclSig sigs `thenM` \ sigs' -> - returnM (tyvars', context', fds', sigs') - ) `thenM` \ (tyvars', context', fds', sigs') -> + returnM (tyvars', context', fds', (ats', ats_fvs), sigs') + ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') -> + + -- Check for duplicates among the associated types + let + at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats] + in + checkDupNames at_doc at_rdr_names_w_locs `thenM_` -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). @@ -555,17 +625,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds ) `thenM` \ (mbinds', meth_fvs) -> - returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'}, + returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', + tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` hsSigsFVs sigs' `plusFV` - meth_fvs) + meth_fvs `plusFV` + ats_fvs) where meth_doc = text "In the default-methods for class" <+> ppr cname cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname + at_doc = text "In the associated types for class" <+> ppr cname badGadtStupidTheta tycon = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"), @@ -579,6 +652,14 @@ badGadtStupidTheta tycon %********************************************************* \begin{code} +-- 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) +-- +rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) +rnTyPats _ Nothing = return Nothing +rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats + rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] rnConDecls tycon condecls = mappM (wrapLocM rnConDecl) condecls @@ -644,6 +725,101 @@ 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.