X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=993db644bdd351d0707acaf1584db71da6219f37;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hp=5083044a6fe3443b1cb6a6ff890ab66cbe867966;hpb=bd865113a1446bb18fb32b546b8776b846a23116;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5083044..993db64 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 ; @@ -103,26 +105,34 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; (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 ; - + + -- At this point, stop if we have found errors. Otherwise + -- the rnDocEntity stuff reports the errors again. + failIfErrsM ; + + rn_docs <- mapM rnDocEntity 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 @@ -137,6 +147,28 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, return (tcg_env `addTcgDUs` src_dus, rn_group) }}} +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) + rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] rnTyClDecls tycl_decls = do (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls @@ -282,12 +314,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,30 +364,26 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- to remove the context). \end{code} -Renaming of the associated type definitions in instances. +Renaming of the associated types in instances. -* In the case of associated data and newtype definitions we add the instance - context. * 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 rnAtDef) atDecls +rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATInsts atDecls = + mapFvRn (wrapLocFstM rnATInst) atDecls where - rnAtDef tydecl@TyFunction {} = + rnATInst tydecl@TyFunction {} = do addErr noKindSig rnTyClDecl tydecl - rnAtDef tydecl@TySynonym {} = rnTyClDecl tydecl - rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = + rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl + rnATInst tydecl@TyData {} = do checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig - rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)}) - -- The source loc is somewhat half hearted... -=chak - rnAtDef _ = - panic "RnSource.rnATDefs: not a type declaration" + rnTyClDecl tydecl + rnATInst _ = + panic "RnSource.rnATInsts: not a type declaration" noKindSig = text "Instances cannot have kind signatures" \end{code} @@ -373,6 +400,20 @@ 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 n) + = do ty' <- rnLHsType (text "a deriving decl") ty + n' <- lookupLocatedOccRn n + let fvs = extractHsTyNames ty' `addOneFV` unLoc n' + return (DerivDecl ty' n', fvs) +\end{code} %********************************************************* %* * @@ -513,7 +554,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, = 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 @@ -526,11 +569,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 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 = 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') @@ -544,8 +593,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 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 @@ -568,21 +621,28 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, rnTyClDecl (tydecl@TyFunction {}) = rnTySig tydecl bindTyVarsRn -rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- lookupLocatedTopBndrRn name + 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) } + 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}) + tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) = lookupLocatedTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures @@ -591,8 +651,9 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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') -> + mapM rnDocEntity docs `thenM` \ docs' -> + returnM (tyvars', context', fds', (ats', ats_fvs), sigs', docs') + ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') -> -- Check for duplicates among the associated types let @@ -634,7 +695,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats'}, + tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` @@ -672,7 +733,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 @@ -691,12 +752,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)) @@ -725,12 +788,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) + 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) @@ -763,7 +828,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, @@ -774,7 +840,8 @@ 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" @@ -794,8 +861,11 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats 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) = @@ -803,9 +873,27 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats 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.