Repository : ssh://darcs.haskell.org//srv/darcs/haddock On branch : local
http://hackage.haskell.org/trac/ghc/changeset/8e73bd1a43036a5d88f61584ffccb2b89c5f9ac5 >--------------------------------------------------------------- commit 8e73bd1a43036a5d88f61584ffccb2b89c5f9ac5 Author: David Waern <[email protected]> Date: Wed Jan 25 00:44:15 2012 +0100 Fix bug introduced in my recent refactoring. >--------------------------------------------------------------- src/Haddock/Interface/Create.hs | 34 ++++++++++--------- .../tests/DeprecatedReExportedFunction.hs | 2 + 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 9028f5f..9cafbc0 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -452,13 +452,12 @@ mkExportItems declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = - let (doc, subs) = exportDecl t docMap argMap subMap in case findDecl t of - [L _ (ValD _)] -> do + ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem t doc return [export] - ds | decl : _ <- filter (not . isValD . unLoc) ds -> + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ @@ -480,7 +479,7 @@ mkExportItems return [] -- normal case - | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ] + | otherwise -> return [ mkExportDecl t newDecl docs_ ] where -- A single signature might refer to many names, but we -- create an export item for a single name only. So we @@ -493,7 +492,7 @@ mkExportItems _ -> decl -- Declaration from another package - [] -> do + ([], _) -> do mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -507,7 +506,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> do - return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -524,13 +523,15 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> [LHsDecl Name] - findDecl name - | mdl == thisMod = maybe [] id (M.lookup name declMap) - | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface)) - | otherwise = [] + findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl n + | m == thisMod, Just ds <- M.lookup n declMap = + (ds, lookupDocs n docMap argMap subMap) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupInstDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) where - mdl = nameModule name + m = nameModule n hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) @@ -551,8 +552,9 @@ hiValExportItem name doc = do Just decl -> return (ExportDecl decl doc [] []) -exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -exportDecl name docMap argMap subMap = +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs name docMap argMap subMap = let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in let doc = (M.lookup name docMap, lookupArgMap name) in let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in @@ -647,12 +649,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = exportDecl name docMap argMap subMap in + let (doc, _) = lookupDocs name docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = exportDecl name docMap argMap subMap in + let (doc, subs) = lookupDocs name docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing diff --git a/tests/html-tests/tests/DeprecatedReExportedFunction.hs b/tests/html-tests/tests/DeprecatedReExportedFunction.hs new file mode 100644 index 0000000..220f107 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedReExportedFunction.hs @@ -0,0 +1,2 @@ +module DeprecatedReExportedFunction (foo) where +import DeprecatedFunction (foo) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
