From c3f8f4f1ab6ef0e0ba46e838055c938c061b6161 Mon Sep 17 00:00:00 2001 From: davve Date: Sat, 29 Jul 2006 21:37:48 +0000 Subject: Complete the renamer --- src/HaddockRename.hs | 362 ++++++++++++++++++++++++++++++--------------------- src/HaddockTypes.hs | 4 +- src/Main.hs | 48 +++++-- 3 files changed, 252 insertions(+), 162 deletions(-) (limited to 'src') diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 922b362d..45db4433 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -25,6 +25,9 @@ import Control.Monad hiding ( mapM ) import Data.Traversable import GHC +import BasicTypes +import SrcLoc +import Bag -- ----------------------------------------------------------------------------- -- Monad for renaming @@ -72,193 +75,248 @@ runRnFM env rn = unRn rn lkp runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n]) runRn lkp rn = unRn rn lkp +-- ----------------------------------------------------------------------------- +-- Renaming + renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName] renameExportItems items = mapM renameExportItem items renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) renameMaybeDoc mbDoc = mapM renameDoc mbDoc +renameLDoc (L loc doc) = return . L loc =<< renameDoc doc + renameDoc :: HsDoc Name -> RnM (HsDoc DocName) renameDoc doc = case doc of - DocEmpty -> return DocEmpty - DocAppend a b -> do a' <- renameDoc a b' <- renameDoc b return (DocAppend a' b') - DocString str -> return (DocString str) - DocParagraph doc -> do doc' <- renameDoc doc return (DocParagraph doc') - DocIdentifier ids -> do lkp <- getLookupRn case [ n | (True, n) <- map lkp ids ] of ids'@(_:_) -> return (DocIdentifier ids') [] -> return (DocIdentifier (map Link ids)) - DocModule str -> return (DocModule str) - DocEmphasis doc -> do doc' <- renameDoc doc return (DocEmphasis doc') - DocMonospaced doc -> do doc' <- renameDoc doc return (DocMonospaced doc') - DocUnorderedList docs -> do docs' <- mapM renameDoc docs return (DocUnorderedList docs') - DocOrderedList docs -> do docs' <- mapM renameDoc docs return (DocOrderedList docs') - --- ----------------------------------------------------------------------------- --- Renaming source code & documentation -{- - -renameDecl :: HsDecl -> RnM HsDecl -renameDecl decl - = case decl of - HsTypeDecl loc t args ty0 doc0 -> do - ty <- renameType ty0 - doc <- renameMaybeDoc doc0 - return (HsTypeDecl loc t args ty doc) - HsDataDecl loc ctx0 t args cons0 drv0 doc0 -> do - ctx <- renameContext ctx0 - cons <- mapM renameConDecl cons0 - drv <- mapM (lookupRn id) drv0 - doc <- renameMaybeDoc doc0 - return (HsDataDecl loc ctx t args cons drv doc) - HsNewTypeDecl loc ctx0 t args con0 drv0 doc0 -> do - ctx <- renameContext ctx0 - con <- renameConDecl con0 - drv <- mapM (lookupRn id) drv0 - doc <- renameMaybeDoc doc0 - return (HsNewTypeDecl loc ctx t args con drv doc) - HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do - ctxt <- renameContext ctxt0 - decls <- mapM renameDecl decls0 - doc <- renameMaybeDoc doc0 - return (HsClassDecl loc ctxt nm tvs fds decls doc) - HsTypeSig loc fs qt0 doc0 -> do - qt <- renameType qt0 - doc <- renameMaybeDoc doc0 - return (HsTypeSig loc fs qt doc) - HsForeignImport loc cc safe ent n ty0 doc0 -> do - ty <- renameType ty0 - doc <- renameMaybeDoc doc0 - return (HsForeignImport loc cc safe ent n ty doc) - HsInstDecl loc ctxt0 asst0 decls -> do - ctxt <- renameContext ctxt0 - asst <- renamePred asst0 - return (HsInstDecl loc ctxt asst decls) - HsDocCommentNamed loc name doc0 -> do - doc <- renameDoc doc0 - return (HsDocCommentNamed loc name doc) - _ -> - return decl - -renameConDecl :: HsConDecl -> RnM HsConDecl -renameConDecl (HsConDecl loc nm tvs ctxt tys0 doc0) = do - tys <- mapM renameBangTy tys0 - doc <- renameMaybeDoc doc0 - return (HsConDecl loc nm tvs ctxt tys doc) -renameConDecl (HsRecDecl loc nm tvs ctxt fields0 doc0) = do - fields <- mapM renameField fields0 - doc <- renameMaybeDoc doc0 - return (HsRecDecl loc nm tvs ctxt fields doc) - -renameField :: HsFieldDecl -> RnM HsFieldDecl -renameField (HsFieldDecl ns ty0 doc0) = do - ty <- renameBangTy ty0 - doc <- renameMaybeDoc doc0 - return (HsFieldDecl ns ty doc) - -renameBangTy :: HsBangType -> RnM HsBangType -renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty -renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty - -renameContext :: HsContext -> RnM HsContext -renameContext = mapM renamePred - -renameIPContext :: HsIPContext -> RnM HsIPContext -renameIPContext cs = mapM renameCtxt cs - where - renameCtxt (HsIP n t) = liftM (HsIP n) (renameType t) - renameCtxt (HsAssump c) = liftM HsAssump (renamePred c) - -renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType]) -renamePred (c,tys0) = do - tys <- mapM renameType tys0 - lookupRn (\c' -> (c',tys)) c - -renameType :: HsType -> RnM HsType -renameType (HsForAllType tvs ctx0 ty0) = do - ctx <- renameIPContext ctx0 - ty <- renameType ty0 - return (HsForAllType tvs ctx ty) -renameType (HsTyFun arg0 res0) = do - arg <- renameType arg0 - res <- renameType res0 - return (HsTyFun arg res) -renameType (HsTyIP n ty0) = do - ty <- renameType ty0 - return (HsTyIP n ty0) -renameType (HsTyTuple b tys0) = do - tys <- mapM renameType tys0 - return (HsTyTuple b tys) -renameType (HsTyApp ty0 arg0) = do - ty <- renameType ty0 - arg <- renameType arg0 - return (HsTyApp ty arg) -renameType (HsTyVar nm) = - return (HsTyVar nm) -renameType (HsTyCon nm) = - lookupRn HsTyCon nm -renameType (HsTyDoc ty0 doc0) = do - ty <- renameType ty0 - doc <- renameDoc doc0 - return (HsTyDoc ty doc) - -renameInstHead :: InstHead -> RnM InstHead -renameInstHead (ctx,asst) = do - ctx <- renameContext ctx - asst <- renamePred asst - return (ctx,asst) - --- ----------------------------------------------------------------------------- - -renameExportItems :: [ExportItem] -> RnM [ExportItem] -renameExportItems items = mapM rn items + DocDefList docs -> do + docs' <- mapM (\(a,b) -> do + a' <- renameDoc a + b' <- renameDoc b + return (a',b')) docs + return (DocDefList docs') + DocCodeBlock doc -> do + doc' <- renameDoc doc + return (DocCodeBlock doc') + DocURL str -> return (DocURL str) + DocAName str -> return (DocAName str) + +rename = lookupRn id +renameL (L loc name) = return . L loc =<< rename name + +renameLPred (L loc p) = return . L loc =<< renamePred p + +renamePred :: HsPred Name -> RnM (HsPred DocName) +renamePred (HsClassP name types) = do + name' <- rename name + types' <- mapM renameLType types + return (HsClassP name' types') +renamePred (HsIParam (Dupable name) t) = do + name' <- rename name + t' <- renameLType t + return (HsIParam (Dupable name') t') +renamePred (HsIParam (Linear name) t) = do + name' <- rename name + t' <- renameLType t + return (HsIParam (Linear name') t') + +renameLType (L loc t) = return . L loc =<< renameType t + +renameType t = case t of + HsForAllTy expl tyvars lcontext ltype -> do + tyvars' <- mapM renameLTyVarBndr tyvars + lcontext' <- renameLContext lcontext + ltype' <- renameLType ltype + return (HsForAllTy expl tyvars' lcontext' ltype') + + HsTyVar n -> return . HsTyVar =<< rename n + HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + + HsAppTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsAppTy a' b') + + HsFunTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsFunTy a' b') + + HsListTy t -> return . HsListTy =<< renameLType t + HsPArrTy t -> return . HsPArrTy =<< renameLType t + + HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts + + HsOpTy a (L loc op) b -> do + op' <- rename op + a' <- renameLType a + b' <- renameLType b + return (HsOpTy a' (L loc op') b') + + HsParTy t -> return . HsParTy =<< renameLType t + + HsNumTy n -> return (HsNumTy n) + + HsPredTy p -> return . HsPredTy =<< renamePred p + + HsKindSig t k -> do + t' <- renameLType t + return (HsKindSig t' k) + + HsDocTy t doc -> do + t' <- renameLType t + doc' <- renameLDoc doc + return (HsDocTy t' doc') + + _ -> error "renameType" + +renameLTyVarBndr (L loc tv) = do + name' <- rename (hsTyVarName tv) + return $ L loc (replaceTyVarName tv name') + +renameLContext (L loc context) = do + context' <- mapM renameLPred context + return (L loc context') + +renameInstHead :: InstHead2 Name -> RnM (InstHead2 DocName) +renameInstHead (preds, className, types) = do + preds' <- mapM renamePred preds + className' <- rename className + types' <- mapM renameType types + return (preds', className', types') + +renameLDecl (L loc d) = return . L loc =<< renameDecl d + +renameDecl d = case d of + TyClD d doc -> do + d' <- renameTyClD d + doc' <- renameMaybeDoc doc + return (TyClD d' doc') + SigD s doc -> do + s' <- renameSig s + doc' <- renameMaybeDoc doc + return (SigD s' doc') + ForD d doc -> do + d' <- renameForD d + doc' <- renameMaybeDoc doc + return (ForD d' doc') + _ -> error "renameDecl" + +renameTyClD d = case d of + ForeignType name a b -> do + name' <- renameL name + return (ForeignType name' a b) + + TyData x lcontext lname ltyvars k cons _ -> do + lcontext' <- renameLContext lcontext + lname' <- renameL lname + ltyvars' <- mapM renameLTyVarBndr ltyvars + cons' <- mapM renameLCon cons + -- we don't need the derivings + return (TyData x lcontext' lname' ltyvars' k cons' Nothing) + + TySynonym lname ltyvars ltype -> do + lname' <- renameL lname + ltyvars' <- mapM renameLTyVarBndr ltyvars + ltype' <- renameLType ltype + return (TySynonym lname' ltyvars' ltype') + + ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ -> do + lcontext' <- renameLContext lcontext + lname' <- renameL lname + ltyvars' <- mapM renameLTyVarBndr ltyvars + lfundeps' <- mapM renameLFunDep lfundeps + lsigs' <- mapM renameLSig lsigs + -- we don't need the default methods or the already collected doc entities + return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag []) + + where + renameLCon (L loc con) = return . L loc =<< renameCon con + renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do + lname' <- renameL lname + ltyvars' <- mapM renameLTyVarBndr ltyvars + lcontext' <- renameLContext lcontext + details' <- renameDetails details + restype' <- renameResType restype + mbldoc' <- mapM renameLDoc mbldoc + return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') + + renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields + renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') + + renameField (HsRecField id arg doc) = do + id' <- renameL id + arg' <- renameLType arg + doc' <- mapM renameLDoc doc + return (HsRecField id' arg' doc') + + renameResType (ResTyH98) = return ResTyH98 + renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameSig sig = case sig of + TypeSig lname ltype -> do + lname' <- renameL lname + ltype' <- renameLType ltype + return (TypeSig lname' ltype') + SpecSig lname ltype x -> do + lname' <- renameL lname + ltype' <- renameLType ltype + return (SpecSig lname' ltype' x) + InlineSig lname x -> do + lname' <- renameL lname + return (InlineSig lname' x) + SpecInstSig t -> return . SpecInstSig =<< renameLType t + FixSig fsig -> return . FixSig =<< renameFixitySig fsig where - rn (ExportModule mod0) - = return (ExportModule mod0) - rn (ExportGroup lev id0 doc0) - = do doc <- renameDoc doc0 - return (ExportGroup lev id0 doc) - rn (ExportDecl x decl0 insts) -- x is an original name, don't rename it - = do decl <- renameDecl decl0 - insts <- mapM renameInstHead insts - return (ExportDecl x decl insts) - rn (ExportNoDecl x y subs) - = do y' <- lookupRn id y - subs' <- mapM (lookupRn id) subs - return (ExportNoDecl x y' subs') - rn (ExportDoc doc0) - = do doc <- renameDoc doc0 - return (ExportDoc doc) --} - -renameInstHead = undefined - - -renameDecl = undefined + renameFixitySig (FixitySig lname x) = do + lname' <- renameL lname + return (FixitySig lname' x) + +renameForD (ForeignImport lname ltype x y) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignImport lname' ltype' x y) +renameForD (ForeignExport lname ltype x y) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignExport lname' ltype' x y) renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName) renameExportItem item = case item of @@ -267,7 +325,7 @@ renameExportItem item = case item of doc' <- renameDoc doc return (ExportGroup2 lev id doc') ExportDecl2 x decl doc instances -> do - decl' <- renameDecl decl + decl' <- renameLDecl decl doc' <- mapM renameDoc doc instances' <- mapM renameInstHead instances return (ExportDecl2 x decl' doc' instances') diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index b4cb6921..cd9d4fff 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -114,7 +114,7 @@ data ExportItem2 name GHC.Name -- the original name (GHC.LHsDecl name) -- a declaration (Maybe (GHC.HsDoc name)) -- maybe a doc comment - [InstHead2] -- instances relevant to this declaration + [InstHead2 name] -- instances relevant to this declaration | ExportNoDecl2 -- an exported entity for which we have no documentation -- (perhaps becuase it resides in another package) @@ -135,7 +135,7 @@ data ExportItem2 name type InstHead = (HsContext,HsAsst) -type InstHead2 = ([GHC.TyVar], [GHC.PredType], GHC.Class, [GHC.Type]) +type InstHead2 name = ([GHC.HsPred name], name, [GHC.HsType name]) type ModuleMap = Map Module Interface type ModuleMap2 = Map GHC.Module HaddockModule diff --git a/src/Main.hs b/src/Main.hs index 13c1b129..ac33796d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,7 +25,7 @@ import Control.Monad ( when ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) -import Data.List ( nub, (\\), foldl', sortBy ) +import Data.List ( nub, (\\), foldl', sortBy, foldl1 ) import Data.Maybe ( isJust, isNothing, maybeToList, listToMaybe ) --import Debug.Trace import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) @@ -335,7 +335,7 @@ run flags files = do let haddockModules' = attachInstances haddockModules - let renamedModules = runWriter $ mapM (renameModule env) haddockModules' + let (renamedModules, messages') = runWriter $ mapM (renameModule env) haddockModules' putStrLn "pass 1 messages:" print messages @@ -347,6 +347,7 @@ run flags files = do putStrLn "pass 2 export items:" printSDoc (ppr renamedModules) defaultUserStyle + mapM_ putStrLn messages' --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules) --printSDoc (ppr group) defaultUserStyle @@ -830,15 +831,17 @@ renameModule renamingEnv mod = (finalModuleDoc, missingNames2) = runRnFM localEnv (renameMaybeDoc (hmod_doc mod)) - missingNames = map (showSDoc . ppr) (nub (missingNames1 ++ missingNames2)) + missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2) + strings = map (showSDoc . ppr) missingNames + in do -- report things that we couldn't link to. Only do this -- for non-hidden modules. when (OptHide `notElem` hmod_options mod && - not (null missingNames)) $ + not (null strings)) $ tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ ": could not find link destinations for:\n"++ - " " ++ concat (map (' ':) missingNames) + " " ++ concat (map (' ':) strings) ] -- trace (show (Map.toAscList import_env)) $ do @@ -1231,7 +1234,7 @@ data SimpleType = SimpleType GHC.Name [SimpleType] deriving (Eq,Ord) attachInstances :: [HaddockModule] -> [HaddockModule] attachInstances modules = map attach modules where - instMap = fmap (sortImage instHead) $ collectInstances modules + instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules attach mod = mod { hmod_export_items = newItems } where newItems = map attachExport (hmod_export_items mod) @@ -1244,7 +1247,7 @@ attachInstances modules = map attach modules collectInstances :: [HaddockModule] - -> Map GHC.Name [InstHead2] -- maps class/type names to instances + -> Map GHC.Name [([GHC.TyVar], [GHC.PredType], Class, [Type])] -- maps class/type names to instances collectInstances modules = Map.fromListWith (flip (++)) tyInstPairs `Map.union` @@ -1256,7 +1259,7 @@ collectInstances modules tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] -instHead :: InstHead2 -> ([Int], GHC.Name, [SimpleType]) +instHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> ([Int], GHC.Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) where @@ -1289,6 +1292,35 @@ funTyConName = mkWiredInName gHC_PRIM (ATyCon funTyCon) -- Relevant TyCon BuiltInSyntax +toHsInstHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> InstHead2 GHC.Name +toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) + +toHsPred :: PredType -> GHC.HsPred GHC.Name +toHsPred (ClassP cls ts) = GHC.HsClassP (className cls) (map toLHsType ts) +toHsPred (IParam n t) = GHC.HsIParam n (toLHsType t) + +toLHsType = noLoc . toHsType + +toHsType :: Type -> GHC.HsType GHC.Name +toHsType t = case t of + TyVarTy v -> GHC.HsTyVar (tyVarName v) + AppTy a b -> GHC.HsAppTy (toLHsType a) (toLHsType b) + TyConApp tc ts -> case ts of + [] -> GHC.HsTyVar (tyConName tc) + _ -> GHC.HsAppTy (tycon tc) (args ts) + FunTy a b -> GHC.HsFunTy (toLHsType a) (toLHsType b) + ForAllTy v t -> cvForAll [v] t + PredTy p -> GHC.HsPredTy (toHsPred p) + NoteTy _ t -> toHsType t + where + + tycon tc = noLoc (GHC.HsTyVar (tyConName tc)) + args ts = foldl1 (\a b -> noLoc $ GHC.HsAppTy a b) (map toLHsType ts) + + cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t + cvForAll vs t = GHC.mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) + tyvarbinders vs = map (noLoc . GHC.UserTyVar . tyVarName) vs + -- ----------------------------------------------------------------------------- -- A monad which collects error messages -- cgit v1.2.3