X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=9653bdc0f3ccb4b74d3637d5c06936e017393d99;hp=842f2b298486332a10cf104ec08b72d0c1f84fb9;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=b6eb00d19a99d68f1ac4702737a067fc6af42ea3 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 842f2b2..9653bdc 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,20 +15,20 @@ 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 ) import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, - lookupOccRn, newLocalsRn, + lookupOccRn, lookupTopBndrRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupNames, mapFvRn ) +import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad import HscTypes ( FixityEnv, FixItem(..), @@ -43,7 +43,7 @@ import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) import Maybe ( isNothing, isJust ) -import Monad ( liftM ) +import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) \end{code} @@ -69,11 +69,13 @@ rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) rnSrcDecls (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, + hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls }) + hs_ruleds = rule_decls, + hs_docs = docs }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -99,30 +101,36 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, -- So we content ourselves with gathering uses only; that -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. + traceRn (text "Start rnTyClDecls") ; (rn_tycl_decls, src_fvs1) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; + traceRn (text "finish rnTyClDecls") ; (rn_inst_decls, src_fvs2) <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ; + (rn_deriv_decls, src_fvs_deriv) + <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ; (rn_rule_decls, src_fvs3) <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ; (rn_foreign_decls, src_fvs4) <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ; (rn_default_decls, src_fvs5) <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; - + + rn_docs <- rnDocEntities docs ; + 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_derivds = rn_deriv_decls, hs_fixds = rn_fix_decls, hs_depds = [], hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls } ; + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs -- Note: src_dus will contain *uses* for locally-defined types @@ -149,6 +157,44 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* %* * + HsDoc stuff +%* * +%********************************************************* + +\begin{code} +rnDocEntities :: [DocEntity RdrName] -> RnM [DocEntity Name] +rnDocEntities ents + = ifErrsM (return []) $ + -- Yuk: stop if we have found errors. Otherwise + -- the rnDocEntity stuff reports the errors again. + mapM rnDocEntity ents + +rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name) +rnDocEntity (DocEntity docdecl) = do + rn_docdecl <- rnDocDecl docdecl + return (DocEntity rn_docdecl) +rnDocEntity (DeclEntity name) = do + rn_name <- lookupTopBndrRn name + return (DeclEntity rn_name) + +rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name) +rnDocDecl (DocCommentNext doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) +\end{code} + + +%********************************************************* +%* * Source-code fixity declarations %* * %********************************************************* @@ -282,12 +328,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 +378,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 @@ -361,6 +414,19 @@ extendTyVarEnvForMethodBinds tyvars thing_inside thing_inside \end{code} +%********************************************************* +%* * +\subsection{Stand-alone deriving declarations} +%* * +%********************************************************* + +\begin{code} +rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) +rnSrcDerivDecl (DerivDecl ty) + = do ty' <- rnLHsType (text "a deriving decl") ty + let fvs = extractHsTyNames ty' + return (DerivDecl ty', fvs) +\end{code} %********************************************************* %* * @@ -491,14 +557,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 +582,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 +606,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,47 +630,55 @@ 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) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats}) - = lookupLocatedTopBndrRn cname `thenM` \ cname' -> + tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) + = do { cname' <- lookupLocatedTopBndrRn 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', (ats', ats_fvs), sigs') - ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') -> + ; (tyvars', context', fds', ats', ats_fvs, sigs') + <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do + { context' <- rnContext cls_doc context + ; fds' <- rnFds cls_doc fds + ; (ats', ats_fvs) <- rnATs ats + ; sigs' <- renameSigs okClsDclSig sigs + ; return (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_` + ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats] + ; checkDupNames at_doc at_rdr_names_w_locs -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - let - sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] - in - checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] + ; checkDupNames sig_doc sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. -- The newLocals call is tiresome: given a generic class decl -- class C a where @@ -599,28 +688,31 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- op {| a*b |} (a*b) = ... -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. - extendTyVarEnvForMethodBinds tyvars' ( - getLocalRdrEnv `thenM` \ name_env -> - let - meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds - gen_rdr_tyvars_w_locs = - [ tv | tv <- extractGenericPatTyVars mbinds, - not (unLoc tv `elemLocalRdrEnv` name_env) ] - in - checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` - newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - 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', tcdATs = ats'}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` - hsSigsFVs sigs' `plusFV` - meth_fvs `plusFV` - ats_fvs) + ; (mbinds', meth_fvs) + <- extendTyVarEnvForMethodBinds tyvars' $ do + { name_env <- getLocalRdrEnv + ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds + gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, + not (unLoc tv `elemLocalRdrEnv` name_env) ] + ; checkDupNames meth_doc meth_rdr_names_w_locs + ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs + ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } + + -- Sigh. Check the Haddock docs after the methods, to avoid duplicate errors + -- Example: class { op :: a->a; op2 x = x } + -- Don't want a duplicate complait about op2 + ; docs' <- bindLocalNames (map hsLTyVarName tyvars') $ rnDocEntities docs + + ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', + tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, + + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` + hsSigsFVs sigs' `plusFV` + 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 @@ -652,7 +744,7 @@ rnConDecls tycon condecls = mappM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) -rnConDecl (ConDecl name expl tvs cxt details res_ty) +rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) = do { addLocM checkConName name ; new_name <- lookupLocatedTopBndrRn name @@ -671,12 +763,14 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty) Explicit -> tvs Implicit -> userHsTyVarBndrs implicit_tvs + ; mb_doc' <- rnMbLHsDoc mb_doc + ; bindTyVarsRn doc tvs' $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty - ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }} - where + ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} + where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) @@ -705,49 +799,14 @@ rnConDetails doc (RecCon fields) mappM (rnField doc) fields `thenM` \ new_fields -> returnM (RecCon new_fields) where - field_names = [fld | (fld, _) <- fields] + field_names = [ name | HsRecField name _ _ <- fields ] -rnField doc (name, ty) +-- Document comments are renamed to Nothing here +rnField doc (HsRecField name ty haddock_doc) = lookupLocatedTopBndrRn name `thenM` \ new_name -> rnLHsType doc ty `thenM` \ new_ty -> - returnM (new_name, new_ty) - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form - -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) - -badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -\end{code} - - -%********************************************************* -%* * -\subsection{Support code to rename types} -%* * -%********************************************************* - -\begin{code} -rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] - -rnFds doc fds - = mappM (wrapLocM rn_fds) fds - where - rn_fds (tys1, tys2) - = rnHsTyVars doc tys1 `thenM` \ tys1' -> - rnHsTyVars doc tys2 `thenM` \ tys2' -> - returnM (tys1', tys2') - -rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs -rnHsTyvar doc tyvar = lookupOccRn tyvar + rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> + returnM (HsRecField new_name new_ty new_haddock_doc) -- Rename kind signatures (signatures of indexed data types/newtypes and -- signatures of type functions) @@ -771,8 +830,7 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, 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 { + do { bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; context' <- rnContext (ksig_doc tycon) context ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context', @@ -780,7 +838,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = [], tcdDerivs = Nothing}, delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context') } } + extractHsCtxtTyNames context') + } } where rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, @@ -791,32 +850,96 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, ; tycon' <- lookupLocatedTopBndrRn tycon ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars', tcdIso = tcdIso tydecl, tcdKind = sig}, - emptyFVs) } } + 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 data declarations, type function signatures, and (default) --- type function equations. +-- * 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 (tydelc@TySynonym {}) = panic "!!!TODO: case not impl yet" + rn_at (tydecl@TySynonym {}) = + do + checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns + rnTyClDecl tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" - lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont - -- + 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. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] +\end{code} + + +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* + +\begin{code} +rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] + +rnFds doc fds + = mappM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenM` \ tys1' -> + rnHsTyVars doc tys2 `thenM` \ tys2' -> + returnM (tys1', tys2') + +rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code}