diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaddockRename.hs | 192 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 62 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 4 | ||||
| -rw-r--r-- | src/Main.hs | 1066 |
4 files changed, 372 insertions, 952 deletions
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index d3667d6b..922b362d 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -5,21 +5,26 @@ -- module HaddockRename ( - RnM, runRn, runRnFM, runRnUnqualFM, -- the monad (instance of Monad) + RnM, runRn, runRnFM, -- the monad (instance of Monad) - renameExportList, - renameDecl, - renameExportItems, renameInstHead, - renameDoc, renameMaybeDoc, + --renameExportList, + --renameDecl, + --renameExportItems, renameInstHead, + --renameDoc, renameMaybeDoc, + renameMaybeDoc, renameExportItems, ) where import HaddockTypes import HaddockUtil ( unQual ) -import HsSyn2 +--import HsSyn2 import Map ( Map ) import qualified Map hiding ( Map ) -import Monad +import Prelude hiding ( mapM ) +import Control.Monad hiding ( mapM ) +import Data.Traversable + +import GHC -- ----------------------------------------------------------------------------- -- Monad for renaming @@ -29,11 +34,11 @@ import Monad -- the environment. newtype GenRnM n a = - RnM { unRn :: (n -> (Bool,HsQName)) -- name lookup function + RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function -> (a,[n]) } -type RnM a = GenRnM HsQName a +type RnM a = GenRnM Name a instance Monad (GenRnM n) where (>>=) = thenRn @@ -46,56 +51,76 @@ m `thenRn` k = RnM (\lkp -> case unRn m lkp of (a,out1) -> case unRn (k a) lkp of (b,out2) -> (b,out1++out2)) -getLookupRn :: RnM (HsQName -> (Bool,HsQName)) +getLookupRn :: RnM (Name -> (Bool, DocName)) getLookupRn = RnM (\lkp -> (lkp,[])) -outRn :: HsQName -> RnM () +outRn :: Name -> RnM () outRn name = RnM (\_ -> ((),[name])) -lookupRn :: (HsQName -> a) -> HsQName -> RnM a +lookupRn :: (DocName -> a) -> Name -> RnM a lookupRn and_then name = do lkp <- getLookupRn case lkp name of (False,maps_to) -> do outRn name; return (and_then maps_to) (True, maps_to) -> return (and_then maps_to) -runRnFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName]) +runRnFM :: Map Name Name -> RnM a -> (a,[Name]) runRnFM env rn = unRn rn lkp where lkp n = case Map.lookup n env of - Nothing -> (False, n) -- leave the qualified name - Just q -> (True, q) - --- like runRnFM, but if it can't find a mapping for a name, --- it leaves an unqualified name in place instead. -runRnUnqualFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName]) -runRnUnqualFM env rn = unRn rn lkp - where lkp n = case Map.lookup n env of - Nothing -> (False, unQual n) -- remove the qualifier - Just q -> (True, q) + Nothing -> (False, NoLink n) + Just q -> (True, Link q) -runRn :: (n -> (Bool,HsQName)) -> GenRnM n a -> (a,[n]) +runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n]) runRn lkp rn = unRn rn lkp --- ----------------------------------------------------------------------------- --- Renaming source code & documentation +renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName] +renameExportItems items = mapM renameExportItem items -renameExportList :: [HsExportSpec] -> RnM [HsExportSpec] -renameExportList spec = mapM renameExport spec - where - renameExport (HsEVar x) = lookupRn HsEVar x - renameExport (HsEAbs x) = lookupRn HsEAbs x - renameExport (HsEThingAll x) = lookupRn HsEThingAll x - renameExport (HsEThingWith x cs) = do - cs' <- mapM (lookupRn id) cs - lookupRn (\x' -> HsEThingWith x' cs') x - renameExport (HsEModuleContents m) = return (HsEModuleContents m) - renameExport (HsEGroup lev doc0) = do - doc <- renameDoc doc0 - return (HsEGroup lev doc) - renameExport (HsEDoc doc0) = do - doc <- renameDoc doc0 - return (HsEDoc doc) - renameExport (HsEDocNamed str) = return (HsEDocNamed str) +renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) +renameMaybeDoc mbDoc = mapM renameDoc mbDoc + +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 @@ -208,62 +233,6 @@ renameInstHead (ctx,asst) = do return (ctx,asst) -- ----------------------------------------------------------------------------- --- Renaming documentation - --- Renaming documentation is done by "marking it up" from ordinary Doc --- into (Rn Doc), which can then be renamed with runRn. -markupRename :: DocMarkup [HsQName] (RnM Doc) -markupRename = Markup { - markupEmpty = return DocEmpty, - markupString = return . DocString, - markupParagraph = liftM DocParagraph, - markupAppend = liftM2 DocAppend, - markupIdentifier = lookupForDoc, - markupModule = return . DocModule, - markupEmphasis = liftM DocEmphasis, - markupMonospaced = liftM DocMonospaced, - markupUnorderedList = liftM DocUnorderedList . sequence, - markupOrderedList = liftM DocOrderedList . sequence, - markupDefList = liftM DocDefList . mapM markupDef, - markupCodeBlock = liftM DocCodeBlock, - markupURL = return . DocURL, - markupAName = return . DocAName - } - -markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b) - -renameDoc :: Doc -> RnM Doc -renameDoc = markup markupRename - -renameMaybeDoc :: Maybe Doc -> RnM (Maybe Doc) -renameMaybeDoc Nothing = return Nothing -renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc - --- --------------------------------------------------------------------------- --- Looking up names in documentation - -lookupForDoc :: [HsQName] -> RnM Doc -lookupForDoc qns = do - lkp <- getLookupRn - case [ n | (True,n) <- map lkp qns ] of - ns@(_:_) -> return (DocIdentifier ns) - [] -> -- if we were given a qualified name, but there's nothing - -- matching that name in scope, then just assume its existence - -- (this means you can use qualified names in doc strings wihout - -- worrying about whether the entity is in scope). - let quals = filter isQualified qns in - if (not (null quals)) then - return (DocIdentifier quals) - else do - outRn (head qns) - -- no qualified names: just replace this name with its - -- string representation. - return (DocString (show (head qns))) - where - isQualified (Qual _ _) = True - isQualified _ = False - --- ----------------------------------------------------------------------------- renameExportItems :: [ExportItem] -> RnM [ExportItem] renameExportItems items = mapM rn items @@ -284,3 +253,28 @@ renameExportItems items = mapM rn items rn (ExportDoc doc0) = do doc <- renameDoc doc0 return (ExportDoc doc) +-} + +renameInstHead = undefined + + +renameDecl = undefined + +renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName) +renameExportItem item = case item of + ExportModule2 mod -> return (ExportModule2 mod) + ExportGroup2 lev id doc -> do + doc' <- renameDoc doc + return (ExportGroup2 lev id doc') + ExportDecl2 x decl doc instances -> do + decl' <- renameDecl decl + doc' <- mapM renameDoc doc + instances' <- mapM renameInstHead instances + return (ExportDecl2 x decl' doc' instances') + ExportNoDecl2 x y subs -> do + y' <- lookupRn id y + subs' <- mapM (lookupRn id) subs + return (ExportNoDecl2 x y' subs') + ExportDoc2 doc -> do + doc' <- renameDoc doc + return (ExportDoc2 doc') diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index df059f7d..b4cb6921 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -9,7 +9,8 @@ module HaddockTypes ( NameEnv, Interface(..), ExportItem(..), ExportItem2(..), ModuleMap, ModuleMap2, HaddockModule(..), -- * Misc types - DocOption(..), InstHead, + DocOption(..), InstHead, InstHead2, + DocName(..), ) where import HsSyn2 @@ -108,40 +109,71 @@ data ExportItem | ExportModule -- a cross-reference to another module Module -data ExportItem2 +data ExportItem2 name = ExportDecl2 - GHC.Name -- the original name - (GHC.HsDecl GHC.Name) -- a declaration - (Maybe (GHC.HsDoc GHC.Name)) -- maybe a doc comment - [InstHead] -- instances relevant to this declaration + GHC.Name -- the original name + (GHC.LHsDecl name) -- a declaration + (Maybe (GHC.HsDoc name)) -- maybe a doc comment + [InstHead2] -- instances relevant to this declaration | ExportNoDecl2 -- an exported entity for which we have no documentation -- (perhaps becuase it resides in another package) - GHC.Name -- the original name - GHC.Name -- where to link to - [GHC.Name] -- subordinate names + GHC.Name -- the original name + name -- where to link to + [name] -- subordinate names | ExportGroup2 -- a section heading Int -- section level (1, 2, 3, ... ) String -- section "id" (for hyperlinks) - (GHC.HsDoc GHC.Name) -- section heading text + (GHC.HsDoc name) -- section heading text | ExportDoc2 -- some documentation - (GHC.HsDoc GHC.Name) + (GHC.HsDoc name) | ExportModule2 -- a cross-reference to another module GHC.Module type InstHead = (HsContext,HsAsst) +type InstHead2 = ([GHC.TyVar], [GHC.PredType], GHC.Class, [GHC.Type]) + type ModuleMap = Map Module Interface type ModuleMap2 = Map GHC.Module HaddockModule +data DocName = Link GHC.Name | NoLink GHC.Name + data HaddockModule = HM { + +-- | A value to identify the module + hmod_mod :: GHC.Module, + +-- | The documentation header for this module + hmod_doc :: Maybe (GHC.HsDoc GHC.Name), + +-- | The Haddock options for this module (prune, ignore-exports, etc) hmod_options :: [DocOption], - hmod_exported_decl_map :: Map GHC.Name (GHC.HsDecl GHC.Name), + + hmod_exported_decl_map :: Map GHC.Name (GHC.LHsDecl GHC.Name), hmod_doc_map :: Map GHC.Name (GHC.HsDoc GHC.Name), - hmod_orig_exports :: [ExportItem2], - hmod_documented_exports :: [GHC.Name], - hmod_sub_map :: Map GHC.Name [GHC.Name] + hmod_export_items :: [ExportItem2 GHC.Name], + +-- | All the names that are defined in this module + hmod_locals :: [GHC.Name], + +-- | All the names that are exported by this module + hmod_exports :: [GHC.Name], + +-- | All the visible names exported by this module +-- For a name to be visible, it has to: +-- - be exported normally, and not via a full module re-exportation. +-- - have a declaration in this module or any of it's imports, with the exception +-- that it can't be from another package. +-- Basically, a visible name is a name that will show up in the documentation. +-- for this module. + hmod_visible_exports :: [GHC.Name], + + hmod_sub_map :: Map GHC.Name [GHC.Name], + +-- | The instances exported by this module + hmod_instances :: [GHC.Instance] } diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 35290c27..7ce16cd3 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -143,8 +143,8 @@ addConDocs (x:xs) doc = addConDoc x doc : xs -- --------------------------------------------------------------------------- -- Making abstract declarations -restrictTo :: [GHC.Name] -> (GHC.HsDecl GHC.Name) -> (GHC.HsDecl GHC.Name) -restrictTo names decl = case decl of +restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name) +restrictTo names (L loc decl) = L loc $ case decl of GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType -> GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) }) doc GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType -> diff --git a/src/Main.hs b/src/Main.hs index 7af7e25e..13c1b129 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -55,6 +55,14 @@ import SrcLoc import qualified Digraph as Digraph import Name import Module (moduleString)-- TODO: add an export to GHC API? +import InstEnv +import Class +import TypeRep +import Var +import TyCon +import PrelNames +import FastString +#define FSLIT(x) (mkFastString# (x#)) import qualified DynFlags as DynFlags ----------------------------------------------------------------------------- @@ -236,25 +244,7 @@ run flags files = do prologue <- getPrologue flags - -- grok the --use-package flags - pkg_ifaces_to_read <- getPackageIfaces flags verbose - - let ifaces_to_read = read_iface_flags ++ pkg_ifaces_to_read - - read_iface_stuff <- mapM readIface (map snd ifaces_to_read) - - let - (read_ifacess, doc_envs) = unzip read_iface_stuff - read_ifaces = concat read_ifacess - - ext_doc_env = Map.unions doc_envs - - visible_read_ifaces = filter ((OptHide `notElem`) . iface_options) - read_ifaces - external_mods = map iface_module read_ifaces - pkg_paths = map fst ifaces_to_read - - updateHTMLXRefs pkg_paths read_ifacess +-- updateHTMLXRefs pkg_paths read_ifacess when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ @@ -266,7 +256,7 @@ run flags files = do visible_read_ifaces prologue copyHtmlBits odir libdir css_file -} - when (Flag_GenIndex `elem` flags) $ do +{- when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls visible_read_ifaces @@ -274,7 +264,7 @@ run flags files = do when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths - +-} GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5") let ghcMode = GHC.JustTypecheck session <- GHC.newSession ghcMode @@ -337,13 +327,27 @@ run flags files = do printSDoc (ppr (Map.toList sub_names)) defaultUserStyle -} - let (export_item_map, messages) = runWriter (pass1 sorted_checked_modules' flags) + let (modMap, messages) = runWriter (pass1 sorted_checked_modules' flags) + + haddockModules = catMaybes [ Map.lookup mod modMap | (mod, _) <- sorted_checked_modules' ] + + let env = buildGlobalDocEnv haddockModules + + let haddockModules' = attachInstances haddockModules + + let renamedModules = runWriter $ mapM (renameModule env) haddockModules' putStrLn "pass 1 messages:" print messages putStrLn "pass 1 export items:" - printSDoc (ppr (map (hmod_orig_exports . snd) (Map.toList export_item_map))) defaultUserStyle + printSDoc (ppr (map hmod_export_items haddockModules')) defaultUserStyle + + putStrLn "pass 2 env:" + printSDoc (ppr (Map.toList env)) defaultUserStyle + putStrLn "pass 2 export items:" + printSDoc (ppr renamedModules) defaultUserStyle + --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules) --printSDoc (ppr group) defaultUserStyle @@ -442,13 +446,19 @@ run flags files = do print_ x = printSDoc (ppr x) defaultUserStyle -instance Outputable ExportItem2 where - ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> text (show instns) +instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where + ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> ppr instns ppr (ExportNoDecl2 n1 n2 ns) = text "ExportNoDecl (org name, link name, sub names)" <+> ppr n1 <+> ppr n2 <+> ppr ns ppr (ExportGroup2 lev id doc) = text "ExportGroup (lev, id, doc)" <+> ppr lev <+> ppr doc ppr (ExportDoc2 doc) = text "ExportDoc" <+> ppr doc ppr (ExportModule2 mod) = text "ExportModule" <+> ppr mod +instance Outputable DocName where + ppr (Link name) = ppr name + ppr (NoLink name) = ppr name + +instance OutputableBndr DocName where + pprBndr _ d = ppr d instance Outputable (GHC.DocEntity GHC.Name) where ppr (GHC.DocEntity d) = ppr d @@ -459,7 +469,7 @@ type FullyCheckedModule = (GHC.ParsedSource, GHC.TypecheckedSource, GHC.ModuleInfo) -getDocumentedExports :: [ExportItem2] -> [GHC.Name] +getDocumentedExports :: [ExportItem2 GHC.Name] -> [GHC.Name] getDocumentedExports exports = concatMap getName exports where getName (ExportDecl2 name _ _ _) = [name] @@ -469,40 +479,58 @@ pass1 :: [(GHC.Module, FullyCheckedModule)] -> [Flag] -> ErrMsgM ModuleMap2 pass1 modules flags = worker modules (Map.empty) flags where worker :: [(GHC.Module, FullyCheckedModule)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 - worker [] module_map _ = return module_map - worker ((mod, checked_mod):rest_modules) module_map flags = do + worker [] moduleMap _ = return moduleMap + worker ((mod, checked_mod):rest_modules) moduleMap flags = do let (parsed_source, renamed_source, _, moduleInfo) = checked_mod - (mb_doc_opts, haddock_mod_info, mb_mod_doc) = get_module_stuff parsed_source + (mb_doc_opts, haddock_mod_info, _) = get_module_stuff parsed_source opts <- mk_doc_opts mb_doc_opts - let exportedNames = GHC.modInfoExports moduleInfo - (group, _, mb_exports, doc) = renamed_source + let (group, _, mb_exports, mbModDoc) = renamed_source entities = nubBy sameName (GHC.hs_docs group) - entityNames = getEntityNames entities - exportedDeclMap = mkDeclMap exportedNames group - localDeclMap = mkDeclMap entityNames group - sub_map = mk_sub_map_from_group group exports = fmap (map unLoc) mb_exports - ignore_all_exports = Flag_IgnoreAllExports `elem` flags + + -- lots of names + exportedNames = GHC.modInfoExports moduleInfo + theseEntityNames = entityNames entities + subNames = allSubnamesInGroup group + localNames = theseEntityNames ++ subNames + -- guaranteed to be Just, since the module has been compiled from scratch + scopeNames = fromJust $ GHC.modInfoTopLevelScope moduleInfo + + subMap = mk_sub_map_from_group group + + theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames subMap exports opts + + let exportedDeclMap = mkDeclMap exportedNames group + localDeclMap = mkDeclMap theseEntityNames group docMap = mkDocMap group - - export_items <- mkExportItems module_map mod exportedNames - exportedDeclMap localDeclMap sub_map entities opts - exports ignore_all_exports docMap + + ignore_all_exports = Flag_IgnoreAllExports `elem` flags + + exportItems <- mkExportItems moduleMap mod exportedNames + exportedDeclMap localDeclMap subMap entities opts + exports ignore_all_exports docMap + + let instances = GHC.modInfoInstances moduleInfo let haddock_module = HM { + hmod_mod = mod, + hmod_doc = mbModDoc, hmod_options = opts, - hmod_exported_decl_map = exportedDeclMap, + hmod_locals = localNames, hmod_doc_map = docMap, - hmod_orig_exports = export_items, - hmod_sub_map = sub_map, - hmod_documented_exports = getDocumentedExports export_items + hmod_sub_map = subMap, + hmod_export_items = exportItems, + hmod_exports = exportedNames, + hmod_visible_exports = theseVisibleNames, + hmod_exported_decl_map = exportedDeclMap, + hmod_instances = instances } - let module_map' = Map.insert mod haddock_module module_map - worker rest_modules module_map' flags + let moduleMap' = Map.insert mod haddock_module moduleMap + worker rest_modules moduleMap' flags where get_module_stuff source = @@ -558,8 +586,8 @@ finishedDoc d GHC.DocEmpty rest = rest finishedDoc (GHC.DeclEntity name) doc rest = (name, doc) : rest finishedDoc _ _ rest = rest -get_all_subnames_from_group :: GHC.HsGroup GHC.Name -> [GHC.Name] -get_all_subnames_from_group group = +allSubnamesInGroup :: GHC.HsGroup GHC.Name -> [GHC.Name] +allSubnamesInGroup group = concat [ tail (map unLoc (GHC.tyClDeclNames tycld)) | L _ tycld <- GHC.hs_tyclds group ] mk_sub_map_from_group :: GHC.HsGroup GHC.Name -> Map GHC.Name [GHC.Name] @@ -567,15 +595,15 @@ mk_sub_map_from_group group = Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group, let name:subs = map unLoc (GHC.tyClDeclNames tycld) ] -mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name) +mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.LHsDecl GHC.Name) mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ] where maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ] -getEntityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name] -getEntityNames entities = [ name | GHC.DeclEntity name <- entities ] +entityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name] +entityNames entities = [ name | GHC.DeclEntity name <- entities ] -getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.HsDecl GHC.Name) +getDeclFromGroup :: GHC.HsGroup GHC.Name -> GHC.Name -> Maybe (GHC.LHsDecl GHC.Name) getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds group), getDeclFromTyCls (GHC.hs_tyclds group), getDeclFromFors (GHC.hs_fords group)] of @@ -583,24 +611,24 @@ getDeclFromGroup group name = case catMaybes [getDeclFromVals (GHC.hs_valds gr _ -> Nothing where getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of - [lsig] -> Just (GHC.SigD (unLoc lsig) Nothing) + [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig) Nothing)) _ -> Nothing where matching = [ lsig | lsig <- lsigs, let Just n = GHC.sigName lsig, n == name ] getDeclFromVals _ = error "getDeclFromVals: illegal input" getDeclFromTyCls ltycls = case matching of - [ltycl] -> Just (GHC.TyClD (unLoc ltycl) Nothing) + [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl) Nothing)) _ -> Nothing where matching = [ ltycl | ltycl <- ltycls, name `elem` map unLoc (GHC.tyClDeclNames (unLoc ltycl))] getDeclFromFors lfors = case matching of - [for] -> Just (GHC.ForD for Nothing) + [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for) Nothing)) _ -> Nothing where - matching = [ for | L _ for <- lfors, forName for == name ] + matching = [ for | for <- lfors, forName (unLoc for) == name ] forName (GHC.ForeignExport n _ _ _) = unLoc n forName (GHC.ForeignImport n _ _ _) = unLoc n @@ -618,30 +646,6 @@ updateHTMLXRefs paths ifaces_s = | (fpath, ifaces) <- zip paths ifaces_s, iface <- ifaces ] -{- -parse_file :: FilePath -> IO HsModule -parse_file file = do - bracket - (openFile file ReadMode) - (\h -> hClose h) - (\h -> do stuff <- hGetContents h - case parse stuff (SrcLoc 1 1 file) 1 0 file [] of - Ok _ e -> return e - Failed err -> die (file ++ ':':err ++ "\n") - ) --} -{- -getPrologue :: [Flag] -> IO (Maybe Doc) -getPrologue flags - = case [filename | Flag_Prologue filename <- flags ] of - [] -> return Nothing - [filename] -> do - str <- readFile filename - case parseParas (tokenise str) of - Left err -> dieMsg err - Right doc -> return (Just doc) - _otherwise -> dieMsg "multiple -p/--prologue options" --} getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName)) getPrologue flags @@ -654,63 +658,6 @@ getPrologue flags Right doc -> return (Just doc) _otherwise -> dieMsg "multiple -p/--prologue options" --- --------------------------------------------------------------------------- --- External packages - -getPackageIfaces :: [Flag] -> Bool -> IO [(String,String)] -getPackageIfaces flags verbose = - let - pkgs = [pkg | Flag_UsePackage pkg <- flags] - in -#if __GLASGOW_HASKELL__ < 603 - if (not (null pkgs)) - then die ("-use-package not supported; recompile Haddock with GHC 6.4 or later") - else return [] -#else - do - mb_iface_details <- mapM getPkgIface pkgs - return [ ok | Just ok <- mb_iface_details ] - where - hc_pkg = "ghc-pkg" -- ToDo: flag - - getPkgIface pkg = do - when verbose $ - putStrLn ("querying ghc-pkg for " ++ pkg ++ "...") - getPkgIface' pkg - `catch` (\e -> do - putStrLn ("Warning: cannot use package " ++ pkg ++ ":") - putStrLn (" " ++ show e) - return Nothing) - - getPkgIface' pkg = do - html <- getPkgField pkg "haddock-html" - html_exists <- doesDirectoryExist html - when (not html_exists) $ do - throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist.")) - - iface <- getPkgField pkg "haddock-interfaces" - iface_exists <- doesFileExist iface - when (not iface_exists) $ do - throwIO (ErrorCall ("interface " ++ iface ++ " does not exist.")) - - return (Just (html, iface)) - - getPkgField pkg field = do - (hin,hout,herr,p) <- runInteractiveProcess hc_pkg - ["field", pkg, field] - Nothing Nothing - hClose hin - out <- hGetContents hout - forkIO (hGetContents herr >> return ()) -- just sink the stderr - r <- waitForProcess p - when (r /= ExitSuccess) $ - throwIO (ErrorCall ("ghc-pkg failed")) - let value = dropWhile isSpace $ init $ tail $ dropWhile (/=':') out - when verbose $ - putStrLn (" " ++ field ++ ": " ++ value) - return value -#endif - ----------------------------------------------------------------------------- -- Figuring out the definitions that are exported from a module @@ -862,71 +809,44 @@ mkInterfacePhase1 flags verbose mod_map filename package iface_insts = instances } ) - +-} -- ----------------------------------------------------------------------------- -- Phase 2 -mkInterfacePhase2 - :: Bool -- verbose - -> Interface - -> Map HsQName HsQName -- global doc-name mapping - -> ErrMsgM Interface - -mkInterfacePhase2 verbose iface gbl_doc_env = - case iface of { - Interface { - iface_module = this_mdl, - iface_env = env, - iface_reexported = reexports, - iface_orig_exports = orig_export_items, - iface_doc = orig_module_doc } -> - - let - -- [ The export list from the renamed output (sort of) ] - exported_visible_names = - [orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ] - - -- build the import_env. - import_env = foldl fn gbl_doc_env exported_visible_names - where fn env qnm@(Qual _ nm) = Map.insert qnm (Qual this_mdl nm) env - fn env (UnQual nm) = env - - -- rename names in the exported declarations to point to things that - -- are closer, or maybe even exported by, the current module. - (renamed_export_list, missing_names1) - = runRnUnqualFM import_env (renameExportItems orig_export_items) - - (final_module_doc, missing_names2) - = runRnUnqualFM import_env (renameMaybeDoc orig_module_doc) - - -- we're only interested in reporting missing *qualfied* - -- names, the unqualified ones are the ones that couldn't - -- be resolved in phase 1 and have already been reported. - filtered_missing_names = - filter isQual (missing_names1 ++ missing_names2) - where isQual (Qual _ _) = True - isQual _ = False - - missing_names = map show (nub filtered_missing_names) - in do +renameModule :: Map GHC.Name GHC.Name -> HaddockModule -> ErrMsgM ([ExportItem2 DocName], Maybe (GHC.HsDoc DocName)) +renameModule renamingEnv mod = + + -- first create the local env, where every name exported by this module + -- is mapped to itself, and everything else comes from the global renameing + -- env + let localEnv = foldl fn renamingEnv (hmod_visible_exports mod) + where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env + + -- rename names in the exported declarations to point to things that + -- are closer, or maybe even exported by, the current module. + (renamedExportItems, missingNames1) + = runRnFM localEnv (renameExportItems (hmod_export_items mod)) + (finalModuleDoc, missingNames2) + = runRnFM localEnv (renameMaybeDoc (hmod_doc mod)) + + missingNames = map (showSDoc . ppr) (nub (missingNames1 ++ missingNames2)) + in do -- report things that we couldn't link to. Only do this -- for non-hidden modules. - when (OptHide `notElem` iface_options iface && - not (null missing_names)) $ - tell ["Warning: " ++ show this_mdl ++ + when (OptHide `notElem` hmod_options mod && + not (null missingNames)) $ + tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ ": could not find link destinations for:\n"++ - " " ++ concat (map (' ':) missing_names) + " " ++ concat (map (' ':) missingNames) ] -- trace (show (Map.toAscList import_env)) $ do - return iface{ iface_exports = renamed_export_list, - iface_doc = final_module_doc } - } - + return (renamedExportItems, finalModuleDoc) + -- ----------------------------------------------------------------------------- - +{- -- Try to generate instance declarations for derived instances. -- We can't do this properly without instance inference, but if a type -- variable occurs as a constructor argument, then we can just @@ -1014,15 +934,15 @@ mkExportItems :: ModuleMap2 -> GHC.Module -- this module -> [GHC.Name] -- exported names (orig) - -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps exported names to declarations - -> Map GHC.Name (GHC.HsDecl GHC.Name) -- maps local names to declarations + -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps exported names to declarations + -> Map GHC.Name (GHC.LHsDecl GHC.Name) -- maps local names to declarations -> Map GHC.Name [GHC.Name] -- sub-map for this module -> [GHC.DocEntity GHC.Name] -- entities in the current module -> [DocOption] -> Maybe [GHC.IE GHC.Name] -> Bool -- --ignore-all-exports flag -> Map GHC.Name (GHC.HsDoc GHC.Name) - -> ErrMsgM [ExportItem2] + -> ErrMsgM [ExportItem2 GHC.Name] mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities opts maybe_exps ignore_all_exports docMap @@ -1049,7 +969,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m Just found -> return [ ExportDoc2 found ] -- NOTE: I'm unsure about this. Currently only "External" names are considered. - declWith :: GHC.Name -> ErrMsgM [ ExportItem2 ] + declWith :: GHC.Name -> ErrMsgM [ ExportItem2 GHC.Name ] declWith t | not (isExternalName t) = return [] declWith t | (Just decl, maybeDoc) <- findDecl t @@ -1072,11 +992,11 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m case Map.lookup m mod_map of Just hmod | OptHide `elem` hmod_options hmod - -> return (hmod_orig_exports hmod) + -> return (hmod_export_items hmod) | otherwise -> return [ ExportModule2 m ] Nothing -> return [] -- already emitted a warning in exportedNames - findDecl :: GHC.Name -> (Maybe (GHC.HsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name)) + findDecl :: GHC.Name -> (Maybe (GHC.LHsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name)) findDecl n | not (isExternalName n) = error "This shouldn't happen" findDecl n | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap) @@ -1088,8 +1008,8 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m where m = nameModule n -fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.HsDecl GHC.Name) -> - Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2] +fullContentsOfThisModule :: GHC.Module -> [GHC.DocEntity GHC.Name] -> Map GHC.Name (GHC.LHsDecl GHC.Name) -> + Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2 GHC.Name] fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities where mkExportItem (GHC.DocEntity (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc @@ -1097,133 +1017,27 @@ fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem enti Just decl -> let maybe_doc = Map.lookup name docMap in ExportDecl2 name decl maybe_doc [] Nothing -> error "fullContentsOfThisModule: This shouldn't happen" -{- ---< ----------------------------------------------------------------------------- --- Build the list of items that will become the documentation, from the --- export list. At this point, the list of ExportItems is in terms of --- original names. - -mkExportItems - :: ModuleMap - -> GHC.Module -- this module - -> [GHC.Name] -- exported names (orig) - -> Map HsName HsDecl -- maps local names to declarations - -> Map HsName [HsName] -- sub-map for this module - -> [HsDecl] -- decls in the current module - -> [DocOption] - -> Maybe [HsExportSpec] - -> Bool -- --ignore-all-exports flag - -> ErrMsgM [ExportItem] - -mkExportItems mod_map this_mod exported_names decl_map sub_map decls - opts maybe_exps ignore_all_exports - | isNothing maybe_exps - || ignore_all_exports - || OptIgnoreExports `elem` opts - = everything_local_exported - | Just specs <- maybe_exps - = do - exps <- mapM lookupExport specs - return (concat exps) - where - everything_local_exported = -- everything exported - return (fullContentsOfThisModule this_mod decls) - - lookupExport (HsEVar x) = declWith x - lookupExport (HsEAbs t) = declWith t - lookupExport (HsEThingAll t) = declWith t - lookupExport (HsEThingWith t cs) = declWith t - lookupExport (HsEModuleContents m) = fullContentsOf m - lookupExport (HsEGroup lev doc) = return [ ExportGroup lev "" doc ] - lookupExport (HsEDoc doc) = return [ ExportDoc doc ] - lookupExport (HsEDocNamed str) - = do r <- findNamedDoc str decls - case r of - Nothing -> return [] - Just found -> return [ ExportDoc found ] - - declWith :: HsQName -> ErrMsgM [ ExportItem ] - declWith (UnQual _) = return [] - declWith t@(Qual mdl x) - | Just decl <- findDecl t - = return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ] - | otherwise - = return [ ExportNoDecl t t (map (Qual mdl) subs) ] - -- can't find the decl (it might be from another package), but let's - -- list the entity anyway. Later on, the renamer will change the - -- orig name into the import name, so we get a proper link to - -- the doc for this entity. - where - subs = map nameOfQName subs_qnames - subs_qnames = filter (`elem` exported_names) all_subs_qnames - - all_subs_qnames = map (Qual mdl) all_subs - - all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map - | otherwise = all_subs_of_qname mod_map t - - fullContentsOf m - | m == this_mod = return (fullContentsOfThisModule this_mod decls) - | otherwise = - case Map.lookup m mod_map of - Just iface - | OptHide `elem` iface_options iface - -> return (iface_orig_exports iface) - | otherwise -> return [ ExportModule m ] - Nothing -> return [] -- already emitted a warning in exportedNames - - findDecl :: HsQName -> Maybe HsDecl - findDecl (UnQual _) - = Nothing -- must be a name we couldn't resolve - findDecl (Qual m n) - | m == this_mod = Map.lookup n decl_map - | otherwise = - case Map.lookup m mod_map of - Just iface -> Map.lookup n (iface_decls iface) - Nothing -> Nothing - - -fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem] -fullContentsOfThisModule mdl decls = - map mkExportItem (filter keepDecl decls) - where mkExportItem (HsDocGroup _ lev doc) = ExportGroup lev "" doc - mkExportItem decl = ExportDecl (Qual mdl x) decl [] - where Just x = declMainBinder decl - -keepDecl :: HsDecl -> Bool -keepDecl HsTypeSig{} = True -keepDecl HsTypeDecl{} = True -keepDecl HsNewTypeDecl{} = True -keepDecl HsDataDecl{} = True -keepDecl HsClassDecl{} = True -keepDecl HsDocGroup{} = True -keepDecl HsForeignImport{} = True -keepDecl _ = False - --} - -- Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...) --- We put noSrcSpan everywhere in the cobbled together type signatures since --- they're not actually located in the source code. -extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name +extractDecl :: GHC.Name -> GHC.Module -> GHC.LHsDecl GHC.Name -> GHC.LHsDecl GHC.Name extractDecl name mdl decl - | Just n <- GHC.getMainDeclBinder decl, n == name = decl + | Just n <- GHC.getMainDeclBinder (unLoc decl), n == name = decl | otherwise = - case decl of + case unLoc decl of GHC.TyClD d _ | GHC.isClassDecl d -> let matches = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d - in GHC.SigD (extractClassDecl n mdl tyvar_names s0) Nothing + L pos sig = extractClassDecl n mdl tyvar_names s0 + in L pos (GHC.SigD sig Nothing) _ -> error "internal: extractDecl" GHC.TyClD d _ | GHC.isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d) - in GHC.SigD sig Nothing + L pos sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d) + in L pos (GHC.SigD sig Nothing) _ -> error "internal: extractDecl" where name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d)) @@ -1238,82 +1052,31 @@ rmLoc :: Located a -> Located a rmLoc a = mkNoLoc (unLoc a) -- originally expected unqualified 1:st name, now it doesn't -extractClassDecl :: GHC.Name -> GHC.Module -> [Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name -extractClassDecl c mdl tvs0 (L _ (GHC.TypeSig lname ltype)) = case ltype of +extractClassDecl :: GHC.Name -> GHC.Module -> [Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.LSig GHC.Name +extractClassDecl c mdl tvs0 (L pos (GHC.TypeSig lname ltype)) = case ltype of L _ (GHC.HsForAllTy exp tvs (L _ preds) ty) -> - GHC.TypeSig (rmLoc lname) (mkNoLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty)) - _ -> GHC.TypeSig (rmLoc lname) (mkNoLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype)) + L pos (GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty))) + _ -> L pos (GHC.TypeSig lname (mkNoLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt preds = mkNoLoc (ctxt preds) ctxt preds = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds -extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl" +extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl" extractRecSel :: GHC.Name -> GHC.Module -> GHC.Name -> [Located GHC.Name] -> [GHC.LConDecl GHC.Name] - -> GHC.Sig GHC.Name + -> GHC.LSig GHC.Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" -- originally expected unqualified 3:rd name, now it doesn't extractRecSel nm mdl t tvs (L _ con : rest) = case GHC.con_details con of GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields -> - GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty))) + L (getLoc n) (GHC.TypeSig (mkNoLoc nm) (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ f | f@(GHC.HsRecField n _ _) <- flds, (unLoc n) == nm ] data_ty = foldl (\x y -> mkNoLoc (GHC.HsAppTy x y)) (mkNoLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs) --- Sometimes the declaration we want to export is not the "main" declaration: --- it might be an individual record selector or a class method. In these --- cases we have to extract the required declaration (and somehow cobble --- together a type signature for it...) -{- -extractDecl :: HsName -> Module -> HsDecl -> HsDecl -extractDecl name mdl decl - | Just n <- declMainBinder decl, n == name = decl - | otherwise = - case decl of - HsClassDecl _ _ n tvs _ decls _ -> - case [ d | d@HsTypeSig{} <- decls, - declMainBinder d == Just name ] of - [d0] -> extractClassDecl n mdl tvs d0 - _ -> error "internal: extractDecl" - - HsDataDecl _ _ t tvs cons _ _ -> - extractRecSel name mdl t tvs cons - - HsNewTypeDecl _ _ t tvs con _ _ -> - extractRecSel name mdl t tvs [con] - - _ -> error ("extractDecl: " ++ show decl) - -extractClassDecl :: HsName -> Module -> [HsName] -> HsDecl -> HsDecl -extractClassDecl c mdl tvs0 (HsTypeSig loc [n] ty doc) - = case ty of - HsForAllType tvs ctxt' ty' -> - HsTypeSig loc [n] (HsForAllType tvs (ctxt ++ ctxt') ty') doc - _ -> - HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc - where - ctxt = [HsAssump (Qual mdl c, map HsTyVar tvs0)] -extractClassDecl _ _ _ d = - error $ "Main.extractClassDecl: unexpected decl: " ++ show d - -extractRecSel :: HsName -> Module -> HsName -> [HsName] -> [HsConDecl] - -> HsDecl -extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" -extractRecSel nm mdl t tvs (d@(HsConDecl{}):rest) = - extractRecSel nm mdl t tvs rest -extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest) - | (HsFieldDecl ns ty mb_doc : _) <- matching_fields - = HsTypeSig loc [nm] (HsTyFun data_ty (unbang ty)) mb_doc - | otherwise = extractRecSel nm mdl t tvs rest - where - matching_fields = [ f | f@(HsFieldDecl ns ty mb_doc) <- fields, - nm `elem` ns ] - - data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs) --} -- ----------------------------------------------------------------------------- -- Pruning @@ -1322,109 +1085,57 @@ pruneExportItems items = filter has_doc items where has_doc (ExportDecl _ d _) = isJust (declDoc d) has_doc _ = True --- ----------------------------------------------------------------------------- --- Make a sub-name map for this module - -mkSubNames :: [HsDecl] -> Map HsName [HsName] -mkSubNames decls = - Map.fromList [ (n, subs) | d <- decls, - Just n <- [declMainBinder d], - subs@(_:_) <- [declSubBinders d] ] -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module -{- -exportedNames :: Module -> ModuleMap -> [HsName] - -> Map HsQName HsQName - -> Map HsName [HsName] - -> Maybe [HsExportSpec] - -> [DocOption] - -> ErrMsgM ([HsQName], [HsQName]) - -exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts - | Nothing <- maybe_exps - = return all_local_names_pr - | OptIgnoreExports `elem` opts - = return all_local_names_pr - | Just expspecs <- maybe_exps - = do all_names <- mapM extract expspecs - all_vis_names <- mapM extract_vis expspecs - return (concat all_names, concat all_vis_names) - where - all_local_names = map (Qual mdl) local_names - all_local_names_pr = (all_local_names,all_local_names) - in_scope = Set.fromList (Map.elems orig_env) +visibleNames :: GHC.Module + -> ModuleMap2 + -> [GHC.Name] + -> [GHC.Name] + -> Map GHC.Name [GHC.Name] + -> Maybe [GHC.IE GHC.Name] + -> [DocOption] + -> ErrMsgM [GHC.Name] + +visibleNames mdl modMap localNames scope subMap maybeExps opts + -- if no export list, just return all local names + | Nothing <- maybeExps = return localNames + | OptIgnoreExports `elem` opts = return localNames + | Just expspecs <- maybeExps = do + visibleNames <- mapM extract expspecs + return $ filter isNotPackageName (concat visibleNames) + where + isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap) + where nameMod = nameModule name extract e = case e of - HsEVar x -> return [x] - HsEAbs t -> return [t] - HsEThingAll t@(Qual m x) -> - return (t : filter (`Set.member` in_scope) (map (Qual m) all_subs)) + GHC.IEVar x -> return [x] + GHC.IEThingAbs t -> return [t] + GHC.IEThingAll t -> return (t : all_subs) where - all_subs | m == mdl = Map.findWithDefault [] x sub_map - | otherwise = all_subs_of_qname mod_map t + all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap + | otherwise = all_subs_of_qname modMap t - HsEThingWith t cs -> return (t : cs) - HsEModuleContents m - | m == mdl -> return (map (Qual mdl) local_names) - | otherwise -> - case Map.lookup m mod_map of - Just iface -> - return (filter (`Set.member` in_scope) (Map.elems (iface_env iface))) - Nothing -> - do tell (exportModuleMissingErr mdl m) - return [] - _ -> return [] - - -- Just the names that will be visible in the documentation - -- (ie. omit names exported via a 'module M' export, if we are just - -- going to cross-reference the module). - extract_vis e = - case e of - HsEModuleContents m - | m == mdl -> return (map (Qual mdl) local_names) + GHC.IEThingWith t cs -> return (t : cs) + + GHC.IEModuleContents m + | m == mdl -> return localNames | otherwise -> - case Map.lookup m mod_map of - Just iface - | OptHide `elem` iface_options iface -> - return (filter (`Set.member` in_scope) (Map.elems (iface_env iface))) + case Map.lookup m modMap of + Just mod + | OptHide `elem` hmod_options mod -> + return (filter (`elem` scope) (hmod_exports mod)) | otherwise -> return [] Nothing - -> return [] -- we already emitted a warning above - - -- remaining cases: we have to catch names which are reexported from - -- here, but for which we have no documentation, perhaps because they - -- are from another package. We have to do this by looking for - -- the declaration in the other module. - _ -> do xs <- extract e - return (filter is_documented_here xs) - - is_documented_here (UnQual _) = False - is_documented_here (Qual m n) - | m == mdl = True -- well, it's not documented anywhere else! - | otherwise = - case Map.lookup m mod_map of - Nothing -> False - Just iface -> isJust (Map.lookup n (iface_decls iface)) --} + -> tell ["Can not reexport a package module"] >> return [] + + _ -> return [] + exportModuleMissingErr this mdl = ["Warning: in export list of " ++ show this ++ ": module not found: " ++ show mdl] -{- --- for a given entity, find all the names it "owns" (ie. all the --- constructors and field names of a tycon, or all the methods of a --- class). -all_subs_of_qname :: ModuleMap -> HsQName -> [HsName] -all_subs_of_qname mod_map (Qual mdl nm) = - case Map.lookup mdl mod_map of - Just iface -> Map.findWithDefault [] nm (iface_sub iface) - Nothing -> [] -all_subs_of_qname _ n@(UnQual _) = - error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n --} - -- for a given entity, find all the names it "owns" (ie. all the -- constructors and field names of a tycon, or all the methods of a @@ -1437,83 +1148,6 @@ all_subs_of_qname mod_map name Nothing -> [] | otherwise = error $ "Main.all_subs_of_qname: unexpected unqual'd name" --- ---------------------------------------------------------------------------- --- Building name environments - --- The orig env maps names in the current source file to --- fully-qualified "original" names. -{- -buildOrigEnv :: Module -> Bool -> ModuleMap -> [HsImportDecl] - -> ErrMsgM (Map HsQName HsQName) -buildOrigEnv this_mdl verbose mod_map imp_decls - = do maps <- mapM build imp_decls - return (Map.unions (reverse maps)) - where - build imp_decl@(HsImportDecl _ mdl qual maybe_as _) - = case Map.lookup mdl mod_map of - Nothing -> do - when verbose $ - -- only emit missing module messages when -v is on. Otherwise - -- we get a ton of spurious messages about missing "Prelude". - tell ["Warning: " ++ show this_mdl - ++ ": imported module not found: " ++ show mdl] - return Map.empty - Just iface -> - return (Map.fromList (concat (map orig_map - (processImportDecl mod_map imp_decl)))) - where - - -- bring both qualified and unqualified names into scope, unless - -- the import was 'qualified'. - orig_map (nm,qnm) - | qual = [ (Qual qual_module nm, qnm) ] - | otherwise = [ (Qual qual_module nm, qnm), (UnQual nm, qnm) ] - - qual_module - | Just m <- maybe_as = m - | otherwise = mdl --} -{- -processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)] -processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) - = case Map.lookup mdl mod_map of - Nothing -> [] - Just iface -> imported_names - where - env = iface_env iface - sub = iface_sub iface - - all_names = Map.toAscList env - - imported_names :: [(HsName,HsQName)] - imported_names - = case imp_specs of - Nothing -> all_names - Just (False,specs) -> [ (n,qnm) | (n,qnm) <- all_names, - n `elem` names specs False ] - Just (True, specs) -> [ (n,qnm) | (n,qnm) <- all_names, - n `notElem` names specs True ] - where - names specs is_hiding - = concat (map (spec_names is_hiding) specs) - - -- when hiding, a conid refers to both the constructor and - -- the type/class constructor. - spec_names _hid (HsIVar v) = [v] - spec_names True (HsIAbs (HsTyClsName i)) - = [HsTyClsName i, HsVarName i] - spec_names False (HsIAbs v) = [v] - spec_names _hid (HsIThingAll v) = v : sub_names v - spec_names _hid (HsIThingWith v xs) = v : xs - - sub_names :: HsName -> [HsName] - sub_names nm = - case Map.lookup nm env of - Just qnm -> filter (`Map.member` env) (all_subs_of_qname mod_map qnm) - _ -> [] --} --- ----------------------------------------------------------------------------- - -- | Build a mapping which for each original name, points to the "best" -- place to link to in the documentation. For the definition of -- "best", we use "the module nearest the bottom of the dependency @@ -1523,30 +1157,27 @@ processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. -- -buildGlobalDocEnv :: [Interface] -> Map HsQName HsQName -buildGlobalDocEnv ifaces - = foldl upd Map.empty (reverse ifaces) + +buildGlobalDocEnv :: [HaddockModule] -> Map GHC.Name GHC.Name +buildGlobalDocEnv modules + = foldl upd Map.empty (reverse modules) where - upd old_env iface - | OptHide `elem` iface_options iface + upd old_env mod + | OptHide `elem` hmod_options mod = old_env - | OptNotHome `elem` iface_options iface + | OptNotHome `elem` hmod_options mod = foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where - mdl = iface_module iface - exported_names = filter not_reexported (Map.elems (iface_env iface)) + exported_names = hmod_visible_exports mod + modName = hmod_mod mod - not_reexported (Qual _ n) = n `notElem` iface_reexported iface - not_reexported (UnQual n) = n `notElem` iface_reexported iface - -- UnQual probably shouldn't happen + keep_old env n = Map.insertWith (\new old -> old) + n (nameSetMod n modName) env + keep_new env n = Map.insert n (nameSetMod n modName) env - keep_old env qnm = Map.insertWith (\new old -> old) - qnm (Qual mdl nm) env - where nm = nameOfQName qnm - keep_new env qnm = Map.insert qnm (Qual mdl nm) env - where nm = nameOfQName qnm +nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) Nothing (nameSrcLoc n) builtinDocEnv = Map.fromList (map (\a -> (a,a)) builtinNames) @@ -1557,72 +1188,8 @@ builtinNames = unit_con_name, nil_con_name] -- ----------------------------------------------------------------------------- --- Expand multiple type signatures - -expandDecl :: HsDecl -> [HsDecl] -expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ] -expandDecl (HsClassDecl loc ctxt n tvs fds decls doc) - = [ HsClassDecl loc ctxt n tvs fds (concat (map expandDecl decls)) doc ] -expandDecl d = [ d ] - ------------------------------------------------------------------------------ --- Collecting documentation and attach it to the right declarations -{- -collectDoc :: [HsDecl] -> [HsDecl] -collectDoc decls = collect Nothing DocEmpty decls - -collect :: Maybe HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl] -collect d doc_so_far [] = - case d of - Nothing -> [] - Just d0 -> finishedDoc d0 doc_so_far [] - -collect d doc_so_far (decl:ds) = - case decl of - HsDocCommentNext _ str -> - case d of - Nothing -> collect d (docAppend doc_so_far str) ds - Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str ds) - - HsDocCommentPrev _ str -> collect d (docAppend doc_so_far str) ds - - _other -> - let decl' = collectInDecl decl in - case d of - Nothing -> collect (Just decl') doc_so_far ds - Just d0 -> finishedDoc d0 doc_so_far - (collect (Just decl') DocEmpty ds) - -finishedDoc :: HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl] -finishedDoc d DocEmpty rest = d : rest -finishedDoc d doc rest = d' : rest - where d' = - case d of - HsTypeDecl loc n ns ty _ -> - HsTypeDecl loc n ns ty (Just doc) - HsDataDecl loc ctxt n ns cons drv _ -> - HsDataDecl loc ctxt n ns cons drv (Just doc) - HsNewTypeDecl loc ctxt n ns con drv _ -> - HsNewTypeDecl loc ctxt n ns con drv (Just doc) - HsClassDecl loc ctxt n tvs fds meths _ -> - HsClassDecl loc ctxt n tvs fds meths (Just doc) - HsTypeSig loc ns ty _ -> - HsTypeSig loc ns ty (Just doc) - HsForeignImport loc cc sf str n ty _ -> - HsForeignImport loc cc sf str n ty (Just doc) - _other -> d - -collectInDecl :: HsDecl -> HsDecl -collectInDecl (HsClassDecl loc ctxt n tvs fds meths doc) - = HsClassDecl loc ctxt n tvs fds (collect Nothing DocEmpty meths) doc -collectInDecl decl - = decl --} --- ----------------------------------------------------------------------------- -- Named documentation --- TODO: work out this stuff - findNamedDoc :: String -> [GHC.DocEntity GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name)) findNamedDoc name entities = search entities where search [] = do @@ -1657,244 +1224,71 @@ parseOption "ignore-exports" = return (Just OptIgnoreExports) parseOption "not-home" = return (Just OptNotHome) parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing --- ----------------------------------------------------------------------------- --- Topologically sort the modules +-- simplified type for sorting types, ignoring qualification (not visible +-- in Haddock output) and unifying special tycons with normal ones. +data SimpleType = SimpleType GHC.Name [SimpleType] deriving (Eq,Ord) -sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)] -sortModules mdls = mapM for_each_scc sccs +attachInstances :: [HaddockModule] -> [HaddockModule] +attachInstances modules = map attach modules where - sccs = stronglyConnComp edges - - edges :: [((HsModule,FilePath), Module, [Module])] - edges = [ ((hsmod,file), mdl, get_imps impdecls) - | (hsmod@(HsModule _ mdl _ impdecls _ _ _ _), file) <- mdls - ] - - get_imps impdecls = [ imp | HsImportDecl _ imp _ _ _ <- impdecls ] - - get_mods hsmodules = [ mdl | HsModule _ mdl _ _ _ _ _ _ <- hsmodules ] + instMap = fmap (sortImage instHead) $ collectInstances modules + attach mod = mod { hmod_export_items = newItems } + where + newItems = map attachExport (hmod_export_items mod) - for_each_scc (AcyclicSCC hsmodule) = return hsmodule - for_each_scc (CyclicSCC hsmodules) = - dieMsg ("modules are recursive: " ++ - unwords (map show (get_mods (map fst hsmodules)))) + attachExport (ExportDecl2 n decl doc _) = + ExportDecl2 n decl doc (case Map.lookup n instMap of + Nothing -> [] + Just instheads -> instheads) + attachExport otherExport = otherExport --- ----------------------------------------------------------------------------- --- Collect instances and attach them to declarations - -attachInstances :: [Interface] -> [Interface] -attachInstances mod_ifaces - = map attach mod_ifaces - where - inst_map = fmap (sortImage instHead) $ collectInstances mod_ifaces +collectInstances + :: [HaddockModule] + -> Map GHC.Name [InstHead2] -- maps class/type names to instances - attach iface = iface{ iface_orig_exports = new_exports } - where - new_exports = map attach_export (iface_orig_exports iface) - - attach_export (ExportDecl nm decl _) = - ExportDecl nm decl (case Map.lookup nm inst_map of - Nothing -> [] - Just instheads -> instheads) - attach_export other_export = - other_export - -collectInstances - :: [Interface] - -> Map HsQName [InstHead] -- maps class/type names to instances - -collectInstances ifaces - = Map.fromListWith (flip (++)) ty_inst_pairs `Map.union` - Map.fromListWith (flip (++)) class_inst_pairs +collectInstances modules + = Map.fromListWith (flip (++)) tyInstPairs `Map.union` + Map.fromListWith (flip (++)) classInstPairs where - all_instances = concat (map iface_insts ifaces) - - class_inst_pairs = [ (cls, [(ctxt,(cls,args))]) - | HsInstDecl _ ctxt (cls,args) _ <- all_instances ] - - ty_inst_pairs = [ (nm, [(ctxt,(cls,args))]) - | HsInstDecl _ ctxt (cls,args) _ <- all_instances, - nm <- nub (concat (map freeTyCons args)) - ] - --- simplified type for sorting types, ignoring qualification (not visible --- in Haddock output) and unifying special tycons with normal ones. -data SimpleType = SimpleType HsName [SimpleType] deriving (Eq,Ord) - --- Sort key for instances: --- arities of arguments, to place higher-kind instances --- name of class --- type arguments -instHead :: (HsContext,(HsQName,[HsType])) -> ([Int],HsName,[SimpleType]) -instHead (ctxt,(cls,args)) - = (map argCount args, nameOfQName cls, map simplify args) + allInstances = concat (map hmod_instances modules) + classInstPairs = [ (is_cls inst, [instanceHead inst]) | + inst <- allInstances ] + tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, + Just tycon <- nub (is_tcs inst) ] + +instHead :: InstHead2 -> ([Int], GHC.Name, [SimpleType]) +instHead (_, _, cls, args) + = (map argCount args, className cls, map simplify args) where - argCount (HsTyApp t _) = argCount t + 1 + argCount (AppTy t _) = argCount t + 1 + argCount (TyConApp _ ts) = length ts + argCount (FunTy _ _ ) = 2 + argCount (ForAllTy _ t) = argCount t + argCount (NoteTy _ t) = argCount t argCount _ = 0 - simplify (HsForAllType tvs ctxt t) = simplify t - simplify (HsTyFun t1 t2) = - SimpleType fun_tycon_name [simplify t1, simplify t2] - simplify (HsTyTuple b ts) = - SimpleType (tuple_tycon_name (length ts - 1)) (map simplify ts) - simplify (HsTyApp t1 t2) = SimpleType s (args ++ [simplify t2]) - where (SimpleType s args) = simplify t1 - simplify (HsTyVar v) = SimpleType v [] - simplify (HsTyCon n) = SimpleType (nameOfQName n) [] - simplify (HsTyDoc t _) = simplify t - simplify (HsTyIP n t) = simplify t + simplify (ForAllTy _ t) = simplify t + simplify (FunTy t1 t2) = + SimpleType funTyConName [simplify t1, simplify t2] + simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2]) + where (SimpleType s args) = simplify t1 + simplify (TyVarTy v) = SimpleType (tyVarName v) [] + simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) + simplify (NoteTy _ t) = simplify t + simplify _ = error "simplify" -- sortImage f = sortBy (\x y -> compare (f x) (f y)) sortImage :: Ord b => (a -> b) -> [a] -> [a] sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs] where cmp_fst (x,_) (y,_) = compare x y --- ----------------------------------------------------------------------------- --- The interface file format. --- This has to read interfaces up to Haddock 0.6 (without the short --- document annotations), and interfaces afterwards, so we use the --- FormatVersion hack to work out which one the interface file contains. - -thisFormatVersion :: FormatVersion -thisFormatVersion = mkFormatVersion 2 - --- | How we store interfaces. Not everything is stored. -type StoredInterface2 = - (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])]) - --- | How we store interfaces. Not everything is stored. -type StoredInterface1 = - (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], - [(HsName,[HsName])]) - --- | How we used to store interfaces. -type NullVersionStoredInterface = - (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], - [(HsName,[HsName])]) - -dumpInterfaces :: [Interface] -> Map HsQName HsQName -> FilePath -> IO () -dumpInterfaces interfaces global_doc_env fileName = - do - let - preparedInterfaces :: [StoredInterface2] - preparedInterfaces = map from_interface interfaces - - bh <- openBinMem 100000 - put_ bh thisFormatVersion - put_ bh preparedInterfaces - putDocEnv bh global_doc_env - writeBinMem bh fileName - - -readIface :: FilePath -> IO ([Interface], Map HsQName HsQName) -readIface fileName = do - bh <- readBinMem fileName - formatVersion <- get bh - case formatVersion of - v | v == thisFormatVersion -> do - (stuff :: [StoredInterface2]) <- get bh - doc_env <- getDocEnv bh - return (map to_interface2 stuff, doc_env) - v | v == mkFormatVersion 1 -> do - (stuff :: [StoredInterface1]) <- get bh - return (map to_interface1 stuff, Map.empty) - v | v == nullFormatVersion -> do - (stuff :: [NullVersionStoredInterface]) <- get bh - return (map nullVersion_to_interface stuff, Map.empty) - otherwise -> do - noDieMsg ( - "Warning: The interface file " ++ show fileName - ++ " could not be read.\n" - ++ "Maybe it's from a later version of Haddock?\n") - return ([], Map.empty) - -from_interface :: Interface -> StoredInterface2 -from_interface iface = - ( iface_module iface, - toDescription iface,iface_package iface, - OptHide `elem` iface_options iface, - [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface), - if n /= n' then error "help!" else True], - Map.toAscList (iface_sub iface) - ) - -getDocEnv :: BinHandle -> IO (Map HsQName HsQName) -getDocEnv bh = do - doc_env_list <- get bh - return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) | - (mdl1,nm,mdl2) <- doc_env_list]) - -putDocEnv :: BinHandle -> Map HsQName HsQName -> IO () -putDocEnv bh env = do - let doc_env_list = - [(mdl1,nm,mdl2) | (Qual mdl1 nm, Qual mdl2 _) <- Map.toAscList env] - put_ bh doc_env_list - - -to_interface1 :: StoredInterface1 -> Interface -to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = Map.fromList env, - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = toModuleInfo descriptionOpt, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -to_interface2 :: StoredInterface2 -> Interface -to_interface2 (mdl,descriptionOpt,package, hide, env, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = - Map.fromList [(n,Qual mdl n) | (n,mdl) <- env], - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = toModuleInfo descriptionOpt, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -nullVersion_to_interface :: NullVersionStoredInterface -> Interface -nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = Map.fromList env, - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = emptyModuleInfo, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -toModuleInfo :: Maybe Doc -> ModuleInfo -toModuleInfo descriptionOpt = - emptyModuleInfo {description = descriptionOpt} +funTyConName = mkWiredInName gHC_PRIM + (mkOccNameFS tcName FSLIT("(->)")) + funTyConKey + Nothing -- No parent object + (ATyCon funTyCon) -- Relevant TyCon + BuiltInSyntax - - -- ----------------------------------------------------------------------------- -- A monad which collects error messages |