diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 435 |
1 files changed, 226 insertions, 209 deletions
diff --git a/src/Main.hs b/src/Main.hs index 009f8f03..73f31581 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,7 @@ module Main (main) where -import HsSyn2 +--import HsSyn2 import HaddockHtml import HaddockHoogle import HaddockRename @@ -15,10 +15,9 @@ import HaddockTypes import HaddockUtil import HaddockVersion import Paths_haddock ( getDataDir ) -import Binary2 import Control.Exception ( bracket ) -import Control.Monad ( when ) +import Control.Monad ( when, liftM ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) @@ -36,17 +35,10 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Data.List ( nubBy ) - -#if __GLASGOW_HASKELL__ >= 603 -import System.Process -import System.Exit -import Control.Exception ( Exception(..), throwIO, catch ) -import Prelude hiding (catch) -import System.Directory ( doesDirectoryExist, doesFileExist ) -import Control.Concurrent -#endif +import Data.FunctorM ( fmapM ) import qualified GHC as GHC +import GHC import Outputable import SrcLoc import qualified Digraph as Digraph @@ -246,29 +238,29 @@ run flags files = do die ("-h cannot be used with --gen-index or --gen-contents") GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5") - let ghcMode = GHC.JustTypecheck - session <- GHC.newSession ghcMode - ghcFlags <- GHC.getSessionDynFlags session - ghcFlags' <- GHC.initPackages ghcFlags + let ghcMode = JustTypecheck + session <- newSession ghcMode + ghcFlags <- getSessionDynFlags session + ghcFlags' <- initPackages ghcFlags let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] - (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags + (ghcFlags'', rest) <- parseDynamicFlags ghcFlags' haddockGhcFlags when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") let ghcFlags''' = DynFlags.dopt_set ghcFlags'' DynFlags.Opt_Haddock - sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags''' $ do - GHC.setSessionDynFlags session ghcFlags''' - targets <- mapM (\s -> GHC.guessTarget s Nothing) files - GHC.setTargets session targets - maybe_module_graph <- GHC.depanal session [] True + sorted_checked_modules <- defaultErrorHandler ghcFlags''' $ do + setSessionDynFlags session ghcFlags''' + targets <- mapM (\s -> guessTarget s Nothing) files + setTargets session targets + maybe_module_graph <- depanal session [] True module_graph <- case maybe_module_graph of Just module_graph -> return module_graph Nothing -> die "Failed to load modules\n" - let sorted_modules = concatMap Digraph.flattenSCC (GHC.topSortModuleGraph False module_graph Nothing) - let (modules, filenames) = unzip [ (GHC.ms_mod modsum, fromJust $ GHC.ml_hs_file (GHC.ms_location modsum)) | modsum <- sorted_modules, - fromJust (GHC.ml_hs_file (GHC.ms_location modsum)) `elem` files ] + let sorted_modules = concatMap Digraph.flattenSCC (topSortModuleGraph False module_graph Nothing) + let (modules, filenames) = unzip [ (ms_mod modsum, fromJust $ ml_hs_file (ms_location modsum)) | modsum <- sorted_modules, + fromJust (ml_hs_file (ms_location modsum)) `elem` files ] - mb_checked_modules <- mapM (GHC.checkModule session) modules + mb_checked_modules <- mapM (checkModule session) modules let checked_modules = catMaybes mb_checked_modules if length checked_modules /= length mb_checked_modules then die "Failed to load all modules\n" @@ -286,8 +278,8 @@ run flags files = do let haddockModules' = attachInstances haddockModules - let (renamedModules, messages') = runWriter $ mapM (renameModule env) haddockModules' - + let (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules' + putStrLn "pass 1 messages:" print messages putStrLn "pass 1 export items:" @@ -297,7 +289,7 @@ run flags files = do printSDoc (ppr (Map.toList env)) defaultUserStyle putStrLn "pass 2 export items:" - printSDoc (ppr renamedModules) defaultUserStyle + printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle mapM_ putStrLn messages' let visibleModules = [ m | m <- haddockModules', OptHide `notElem` (hmod_options m) ] @@ -319,25 +311,14 @@ run flags files = do visibleModules prologue copyHtmlBits odir libdir css_file - - --let Just (group, imports, exports) = GHC.renamedSource (head sorted_checked_modules) - --printSDoc (ppr group) defaultUserStyle - --- let exports = GHC.modInfoExports $ fromJust $ GHC.checkedModuleInfo $ snd $ (head sorted_checked_modules) ---- printSDoc (ppr exports) defaultUserStyle - - - - -{- let parsed_source = unLoc $ GHC.parsedSource (head checked_modules) - printSDoc (ppr parsed_source) defaultUserStyle --} + when (Flag_Html `elem` flags) $ do + ppHtml title package visibleModules odir + prologue maybe_html_help_format + maybe_source_urls maybe_wiki_urls + maybe_contents_url maybe_index_url + copyHtmlBits odir libdir css_file return () - -- case successFlag of - -- GHC.Succeeded -> bye "Succeeded" - -- GHC.Failed -> bye "Could not load all targets" - {- parsed_mods <- mapM parse_file files sorted_mod_files <- sortModules (zip parsed_mods files) @@ -414,7 +395,7 @@ run flags files = do remove_maybes modules | length modules' == length modules = return modules' | otherwise = die "Missing checked module phase information\n" - where modules' = [ (mod, (a,b,c,d), f) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d), f) <- modules ] + where modules' = [ (mod, (a,b,c,d), f) | (mod, CheckedModule a (Just b) (Just c) (Just d), f) <- modules ] print_ x = printSDoc (ppr x) defaultUserStyle @@ -425,26 +406,26 @@ instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where 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 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 - ppr (GHC.DeclEntity name) = ppr name +instance Outputable (DocEntity Name) where + ppr (DocEntity d) = ppr d + ppr (DeclEntity name) = ppr name -type FullyCheckedModule = (GHC.ParsedSource, - GHC.RenamedSource, - GHC.TypecheckedSource, - GHC.ModuleInfo) +type FullyCheckedModule = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo) -pass1 :: [(GHC.Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2 +pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2 pass1 modules flags package = worker modules (Map.empty) flags where - worker :: [(GHC.Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 + worker :: [(Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 worker [] moduleMap _ = return moduleMap worker ((mod, checked_mod, filename):rest_modules) moduleMap flags = do @@ -454,16 +435,16 @@ pass1 modules flags package = worker modules (Map.empty) flags opts <- mk_doc_opts mb_doc_opts let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source - entities = nubBy sameName (GHC.hs_docs group) + entities = nubBy sameName (hs_docs group) exports = fmap (map unLoc) mb_exports -- lots of names - exportedNames = GHC.modInfoExports moduleInfo + exportedNames = 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 + scopeNames = fromJust $ modInfoTopLevelScope moduleInfo subMap = mk_sub_map_from_group group @@ -485,18 +466,21 @@ pass1 modules flags package = worker modules (Map.empty) flags | OptPrune `elem` opts = pruneExportItems exportItems | otherwise = exportItems - instances = GHC.modInfoInstances moduleInfo + instances = modInfoInstances moduleInfo haddock_module = HM { hmod_mod = mod, hmod_orig_filename = filename, hmod_info = haddockModInfo, hmod_doc = mbModDoc, + hmod_rn_doc = Nothing, hmod_options = opts, hmod_locals = localNames, hmod_doc_map = docMap, + hmod_rn_doc_map = Map.empty, hmod_sub_map = subMap, hmod_export_items = prunedExportItems, + hmod_rn_export_items = [], hmod_exports = exportedNames, hmod_visible_exports = theseVisibleNames, hmod_exported_decl_map = exportedDeclMap, @@ -510,7 +494,7 @@ pass1 modules flags package = worker modules (Map.empty) flags where get_module_stuff source = - let GHC.HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source + let HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source in (mb_opts, info, mb_doc) mk_doc_opts mb_opts = do @@ -522,21 +506,21 @@ pass1 modules flags package = worker modules (Map.empty) flags else opts return opts' -sameName (GHC.DocEntity _) _ = False -sameName (GHC.DeclEntity _) (GHC.DocEntity _) = False -sameName (GHC.DeclEntity a) (GHC.DeclEntity b) = a == b +sameName (DocEntity _) _ = False +sameName (DeclEntity _) (DocEntity _) = False +sameName (DeclEntity a) (DeclEntity b) = a == b -mkDocMap :: GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDoc GHC.Name) +mkDocMap :: HsGroup Name -> Map Name (HsDoc Name) mkDocMap group = Map.fromList $ - collectDocs (GHC.hs_docs group) ++ collectDocsFromClassMeths (getClasses group) + collectDocs (hs_docs group) ++ collectDocsFromClassMeths (getClasses group) where - getClasses group = filter GHC.isClassDecl (map unLoc (GHC.hs_tyclds group)) - collectDocsFromClassMeths classes = concatMap (collectDocs . GHC.tcdDocs) classes + getClasses group = filter isClassDecl (map unLoc (hs_tyclds group)) + collectDocsFromClassMeths classes = concatMap (collectDocs . tcdDocs) classes -collectDocs :: [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.Name)] -collectDocs entities = collect Nothing GHC.DocEmpty entities +collectDocs :: [DocEntity Name] -> [(Name, HsDoc Name)] +collectDocs entities = collect Nothing DocEmpty entities -collect :: Maybe (GHC.DocEntity GHC.Name) -> GHC.HsDoc GHC.Name -> [GHC.DocEntity GHC.Name] -> [(GHC.Name, GHC.HsDoc GHC.Name)] +collect :: Maybe (DocEntity Name) -> HsDoc Name -> [DocEntity Name] -> [(Name, HsDoc Name)] collect d doc_so_far [] = case d of Nothing -> [] @@ -544,69 +528,99 @@ collect d doc_so_far [] = collect d doc_so_far (e:es) = case e of - GHC.DocEntity (GHC.DocCommentNext str) -> + DocEntity (DocCommentNext str) -> case d of - Nothing -> collect d (GHC.docAppend doc_so_far str) es + Nothing -> collect d (docAppend doc_so_far str) es Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es) - GHC.DocEntity (GHC.DocCommentPrev str) -> collect d (GHC.docAppend doc_so_far str) es + DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es _other -> case d of Nothing -> collect (Just e) doc_so_far es Just d0 -> finishedDoc d0 doc_so_far - (collect (Just e) GHC.DocEmpty es) + (collect (Just e) DocEmpty es) -finishedDoc :: GHC.DocEntity GHC.Name -> GHC.HsDoc GHC.Name -> [(GHC.Name, GHC.HsDoc GHC.Name)] -> [(GHC.Name, GHC.HsDoc GHC.Name)] -finishedDoc d GHC.DocEmpty rest = rest -finishedDoc (GHC.DeclEntity name) doc rest = (name, doc) : rest +finishedDoc :: DocEntity Name -> HsDoc Name -> [(Name, HsDoc Name)] -> [(Name, HsDoc Name)] +finishedDoc d DocEmpty rest = rest +finishedDoc (DeclEntity name) doc rest = (name, doc) : rest finishedDoc _ _ rest = rest -allSubnamesInGroup :: GHC.HsGroup GHC.Name -> [GHC.Name] +allSubnamesInGroup :: HsGroup Name -> [Name] allSubnamesInGroup group = - concat [ tail (map unLoc (GHC.tyClDeclNames tycld)) | L _ tycld <- GHC.hs_tyclds group ] + concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ] -mk_sub_map_from_group :: GHC.HsGroup GHC.Name -> Map GHC.Name [GHC.Name] +mk_sub_map_from_group :: HsGroup Name -> Map Name [Name] mk_sub_map_from_group group = - Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group, - let name:subs = map unLoc (GHC.tyClDeclNames tycld) ] + Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, + let name:subs = map unLoc (tyClDeclNames tycld) ] -mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.LHsDecl GHC.Name) +mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name) mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ] where maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ] -entityNames :: [GHC.DocEntity GHC.Name] -> [GHC.Name] -entityNames entities = [ name | GHC.DeclEntity name <- entities ] - -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 - [decl] -> Just decl +entityNames :: [DocEntity Name] -> [Name] +entityNames entities = [ name | DeclEntity name <- entities ] +{- +getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name) +getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of + [bind] -> -- OK we have found a binding that matches. Now look up the + -- type, even though it may be present in the ValBindsOut + let tything = lookupTypeEnv typeEnv name _ -> Nothing where - getDeclFromVals (GHC.ValBindsOut _ lsigs) = case matching of - [lsig] -> Just (L (getLoc lsig) (GHC.SigD (unLoc lsig))) + binds = snd $ unzip recsAndBinds + matchingBinds = Bag.filter matchesName binds + matchesName (L _ bind) = fun_id bind == name +getValSig _ _ _ = error "getValSig" +-} +getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name) +getDeclFromGroup group name = + case catMaybes [ getDeclFromVals (hs_valds group), + getDeclFromTyCls (hs_tyclds group), + getDeclFromFors (hs_fords group) ] of + [decl] -> Just decl + _ -> Nothing + where + getDeclFromVals (ValBindsOut _ lsigs) = case matching of + [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig))) _ -> Nothing where - matching = [ lsig | lsig <- lsigs, let Just n = GHC.sigName lsig, n == name ] + matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name, + isNormal (unLoc lsig) ] + isNormal (TypeSig _ _) = True + isNormal _ = False + getDeclFromVals _ = error "getDeclFromVals: illegal input" - + +{- getDeclFromVals (ValBindsOut recsAndbinds _) = + let binds = snd $ unzip recsAndBinds + matchingBinds = Bag.filter matchesName binds + matchesName (L _ bind) = fun_id bind == name + in case matchingBinds of + [bind] -> -- OK we have found a binding that matches. Now look up the + -- type, even though it may be present in the ValBindsOut + + _ -> Nothing + where + matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ] + getDeclFromVals _ = error "getDeclFromVals: illegal input" + -} getDeclFromTyCls ltycls = case matching of - [ltycl] -> Just (L (getLoc ltycl) (GHC.TyClD (unLoc ltycl))) + [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl))) _ -> Nothing where matching = [ ltycl | ltycl <- ltycls, - name `elem` map unLoc (GHC.tyClDeclNames (unLoc ltycl))] + name `elem` map unLoc (tyClDeclNames (unLoc ltycl))] getDeclFromFors lfors = case matching of - [for] -> Just (L (getLoc for) (GHC.ForD (unLoc for))) + [for] -> Just (L (getLoc for) (ForD (unLoc for))) _ -> Nothing where matching = [ for | for <- lfors, forName (unLoc for) == name ] - forName (GHC.ForeignExport n _ _ _) = unLoc n - forName (GHC.ForeignImport n _ _ _) = unLoc n + forName (ForeignExport n _ _ _) = unLoc n + forName (ForeignImport n _ _ _) = unLoc n parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = @@ -614,22 +628,22 @@ parseIfaceOption s = (fpath,',':file) -> (fpath,file) (file, _) -> ("", file) -updateHTMLXRefs :: [FilePath] -> [[Interface]] -> IO () -updateHTMLXRefs paths ifaces_s = +updateHTMLXRefs :: [FilePath] -> [[HaddockModule]] -> IO () +updateHTMLXRefs paths hmods_s = writeIORef html_xrefs_ref (Map.fromList mapping) where - mapping = [ (iface_module iface, fpath) - | (fpath, ifaces) <- zip paths ifaces_s, - iface <- ifaces + mapping = [ (hmod_mod hmod, fpath) + | (fpath, hmods) <- zip paths hmods_s, + hmod <- hmods ] -getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName)) +getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing [filename] -> do str <- readFile filename - case GHC.parseHaddockComment str of + case parseHaddockComment str of Left err -> dieMsg err Right doc -> return (Just doc) _otherwise -> dieMsg "multiple -p/--prologue options" @@ -637,7 +651,7 @@ getPrologue flags -- ----------------------------------------------------------------------------- -- Phase 2 -renameModule :: Map GHC.Name GHC.Name -> HaddockModule -> ErrMsgM ([ExportItem2 DocName], Maybe (GHC.HsDoc DocName)) +renameModule :: Map Name Name -> HaddockModule -> ErrMsgM HaddockModule renameModule renamingEnv mod = -- first create the local env, where every name exported by this module @@ -645,31 +659,35 @@ renameModule renamingEnv mod = -- env let localEnv = foldl fn renamingEnv (hmod_visible_exports mod) where fn env name = Map.insert name (nameSetMod name (hmod_mod mod)) env + + docs = Map.toList (hmod_doc_map mod) + renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- rename names in the exported declarations to point to things that - -- are closer, or maybe even exported by, the current module. + -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) = runRnFM localEnv (renameExportItems (hmod_export_items mod)) - (finalModuleDoc, missingNames2) + (rnDocMap, missingNames2) + = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) + + (finalModuleDoc, missingNames3) = runRnFM localEnv (renameMaybeDoc (hmod_doc mod)) - missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2) + missingNames = nub $ filter isExternalName + (missingNames1 ++ missingNames2 ++ missingNames3) 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 strings)) $ + -- report things that we couldn't link to. Only do this for non-hidden modules. + when (OptHide `notElem` hmod_options mod && not (null strings)) $ tell ["Warning: " ++ show (ppr (hmod_mod mod) defaultUserStyle) ++ ": could not find link destinations for:\n"++ - " " ++ concat (map (' ':) strings) - ] - - -- trace (show (Map.toAscList import_env)) $ do + " " ++ concat (map (' ':) strings) ] - return (renamedExportItems, finalModuleDoc) + return $ mod { hmod_rn_doc = finalModuleDoc, + hmod_rn_doc_map = rnDocMap, + hmod_rn_export_items = renamedExportItems } -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the @@ -678,17 +696,17 @@ renameModule renamingEnv mod = mkExportItems :: ModuleMap2 - -> GHC.Module -- this module - -> [GHC.Name] -- exported names (orig) - -> 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 + -> Module -- this module + -> [Name] -- exported names (orig) + -> Map Name (LHsDecl Name) -- maps exported names to declarations + -> Map Name (LHsDecl Name) -- maps local names to declarations + -> Map Name [Name] -- sub-map for this module + -> [DocEntity Name] -- entities in the current module -> [DocOption] - -> Maybe [GHC.IE GHC.Name] + -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag - -> Map GHC.Name (GHC.HsDoc GHC.Name) - -> ErrMsgM [ExportItem2 GHC.Name] + -> Map Name (HsDoc Name) + -> ErrMsgM [ExportItem2 Name] mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_map entities opts maybe_exps ignore_all_exports docMap @@ -701,21 +719,21 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod entities localDeclMap docMap) - lookupExport (GHC.IEVar x) = declWith x - lookupExport (GHC.IEThingAbs t) = declWith t - lookupExport (GHC.IEThingAll t) = declWith t - lookupExport (GHC.IEThingWith t cs) = declWith t - lookupExport (GHC.IEModuleContents m) = fullContentsOf m - lookupExport (GHC.IEGroup lev doc) = return [ ExportGroup2 lev "" doc ] - lookupExport (GHC.IEDoc doc) = return [ ExportDoc2 doc ] - lookupExport (GHC.IEDocNamed str) + lookupExport (IEVar x) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll t) = declWith t + lookupExport (IEThingWith t cs) = declWith t + lookupExport (IEModuleContents m) = fullContentsOf m + lookupExport (IEGroup lev doc) = return [ ExportGroup2 lev "" doc ] + lookupExport (IEDoc doc) = return [ ExportDoc2 doc ] + lookupExport (IEDocNamed str) = do r <- findNamedDoc str entities case r of Nothing -> return [] Just found -> return [ ExportDoc2 found ] -- NOTE: I'm unsure about this. Currently only "External" names are considered. - declWith :: GHC.Name -> ErrMsgM [ ExportItem2 GHC.Name ] + declWith :: Name -> ErrMsgM [ ExportItem2 Name ] declWith t | not (isExternalName t) = return [] declWith t | (Just decl, maybeDoc) <- findDecl t @@ -742,7 +760,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m | otherwise -> return [ ExportModule2 m ] Nothing -> return [] -- already emitted a warning in exportedNames - findDecl :: GHC.Name -> (Maybe (GHC.LHsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name)) + findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name)) findDecl n | not (isExternalName n) = error "This shouldn't happen" findDecl n | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap) @@ -754,76 +772,77 @@ 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.LHsDecl GHC.Name) -> - Map GHC.Name (GHC.HsDoc GHC.Name) -> [ExportItem2 GHC.Name] +fullContentsOfThisModule :: Module -> [DocEntity Name] -> Map Name (LHsDecl Name) -> + Map Name (HsDoc Name) -> [ExportItem2 Name] fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities where - mkExportItem (GHC.DocEntity (GHC.DocGroup lev doc)) = ExportGroup2 lev "" doc - mkExportItem (GHC.DeclEntity name) = case Map.lookup name declMap of - Just decl -> let maybe_doc = Map.lookup name docMap in ExportDecl2 name decl maybe_doc [] - Nothing -> error "fullContentsOfThisModule: This shouldn't happen" + mkExportItem (DocEntity (DocGroup lev doc)) = ExportGroup2 lev "" doc + mkExportItem (DeclEntity name) = trace (show (ppr name defaultUserStyle)) $ case Map.lookup name declMap of + Just decl -> let maybeDoc = Map.lookup name docMap in ExportDecl2 name decl maybeDoc [] + -- this can happen if there was no type signature for a value binding + Nothing -> ExportNoDecl2 name name [] -- 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 :: GHC.Name -> GHC.Module -> GHC.LHsDecl GHC.Name -> GHC.LHsDecl GHC.Name +extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name extractDecl name mdl decl - | Just n <- GHC.getMainDeclBinder (unLoc decl), n == name = decl + | Just n <- getMainDeclBinder (unLoc decl), n == name = decl | otherwise = case unLoc decl of - GHC.TyClD d | GHC.isClassDecl d -> - let matches = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] + TyClD d | isClassDecl d -> + let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name ] in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d L pos sig = extractClassDecl n mdl tyvar_names s0 - in L pos (GHC.SigD sig) + in L pos (SigD sig) _ -> error "internal: extractDecl" - GHC.TyClD d | GHC.isDataDecl d -> + TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (GHC.tcdCons d) - in L pos (GHC.SigD sig) + L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + in L pos (SigD sig) _ -> error "internal: extractDecl" where - name_and_tyvars d = (unLoc (GHC.tcdLName d), GHC.hsLTyVarLocNames (GHC.tcdTyVars d)) + name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d)) -toTypeNoLoc :: Located GHC.Name -> GHC.LHsType GHC.Name -toTypeNoLoc lname = noLoc (GHC.HsTyVar (unLoc lname)) +toTypeNoLoc :: Located Name -> LHsType Name +toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname)) rmLoc :: Located a -> Located a rmLoc a = noLoc (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.LSig GHC.Name -extractClassDecl c mdl tvs0 (L pos (GHC.TypeSig lname ltype)) = case ltype of - L _ (GHC.HsForAllTy exp tvs (L _ preds) ty) -> - L pos (GHC.TypeSig lname (noLoc (GHC.HsForAllTy exp tvs (lctxt preds) ty))) - _ -> L pos (GHC.TypeSig lname (noLoc (GHC.mkImplicitHsForAllTy (lctxt []) ltype))) +extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name +extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of + L _ (HsForAllTy exp tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty))) + _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt preds = noLoc (ctxt preds) - ctxt preds = [noLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds + ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl" -extractRecSel :: GHC.Name -> GHC.Module -> GHC.Name -> [Located GHC.Name] -> [GHC.LConDecl GHC.Name] - -> GHC.LSig GHC.Name +extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name] + -> LSig 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 -> - L (getLoc n) (GHC.TypeSig (noLoc nm) (noLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))) + case con_details con of + RecCon fields | (HsRecField n ty _ : _) <- matching_fields fields -> + L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (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 -> noLoc (GHC.HsAppTy x y)) (noLoc (GHC.HsTyVar t)) (map toTypeNoLoc tvs) + matching_fields flds = [ f | f@(HsRecField n _ _) <- flds, (unLoc n) == nm ] + data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) -- ----------------------------------------------------------------------------- -- Pruning -pruneExportItems :: [ExportItem2 GHC.Name] -> [ExportItem2 GHC.Name] +pruneExportItems :: [ExportItem2 Name] -> [ExportItem2 Name] pruneExportItems items = filter hasDoc items where hasDoc (ExportDecl2 _ _ d _) = isJust d hasDoc _ = True @@ -832,14 +851,14 @@ pruneExportItems items = filter hasDoc items -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module -visibleNames :: GHC.Module +visibleNames :: Module -> ModuleMap2 - -> [GHC.Name] - -> [GHC.Name] - -> Map GHC.Name [GHC.Name] - -> Maybe [GHC.IE GHC.Name] + -> [Name] + -> [Name] + -> Map Name [Name] + -> Maybe [IE Name] -> [DocOption] - -> ErrMsgM [GHC.Name] + -> ErrMsgM [Name] visibleNames mdl modMap localNames scope subMap maybeExps opts -- if no export list, just return all local names @@ -854,16 +873,16 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts extract e = case e of - GHC.IEVar x -> return [x] - GHC.IEThingAbs t -> return [t] - GHC.IEThingAll t -> return (t : all_subs) + IEVar x -> return [x] + IEThingAbs t -> return [t] + IEThingAll t -> return (t : all_subs) where all_subs | nameModule t == mdl = Map.findWithDefault [] t subMap | otherwise = allSubsOfName modMap t - GHC.IEThingWith t cs -> return (t : cs) + IEThingWith t cs -> return (t : cs) - GHC.IEModuleContents m + IEModuleContents m | m == mdl -> return localNames | otherwise -> case Map.lookup m modMap of @@ -879,7 +898,7 @@ visibleNames mdl modMap localNames scope subMap maybeExps opts -- 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). -allSubsOfName :: ModuleMap2 -> GHC.Name -> [GHC.Name] +allSubsOfName :: ModuleMap2 -> Name -> [Name] allSubsOfName mod_map name | isExternalName name = case Map.lookup (nameModule name) mod_map of @@ -897,7 +916,7 @@ allSubsOfName mod_map name -- by reversing the list so we can do a foldl. -- -buildGlobalDocEnv :: [HaddockModule] -> Map GHC.Name GHC.Name +buildGlobalDocEnv :: [HaddockModule] -> Map Name Name buildGlobalDocEnv modules = foldl upd Map.empty (reverse modules) where @@ -921,12 +940,12 @@ nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) Nothi -- ----------------------------------------------------------------------------- -- Named documentation -findNamedDoc :: String -> [GHC.DocEntity GHC.Name] -> ErrMsgM (Maybe (GHC.HsDoc GHC.Name)) +findNamedDoc :: String -> [DocEntity Name] -> ErrMsgM (Maybe (HsDoc Name)) findNamedDoc name entities = search entities where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search ((GHC.DocEntity (GHC.DocCommentNamed name' doc)):rest) + search ((DocEntity (DocCommentNamed name' doc)):rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest @@ -957,7 +976,7 @@ parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing -- 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) +data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) attachInstances :: [HaddockModule] -> [HaddockModule] attachInstances modules = map attach modules @@ -975,7 +994,7 @@ attachInstances modules = map attach modules collectInstances :: [HaddockModule] - -> Map GHC.Name [([GHC.TyVar], [GHC.PredType], Class, [Type])] -- maps class/type names to instances + -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances collectInstances modules = Map.fromListWith (flip (++)) tyInstPairs `Map.union` @@ -987,7 +1006,7 @@ collectInstances modules tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] -instHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> ([Int], GHC.Name, [SimpleType]) +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) where @@ -1020,34 +1039,32 @@ funTyConName = mkWiredInName gHC_PRIM (ATyCon funTyCon) -- Relevant TyCon BuiltInSyntax -toHsInstHead :: ([GHC.TyVar], [GHC.PredType], Class, [Type]) -> InstHead2 GHC.Name +toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead2 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) +toHsPred :: PredType -> HsPred Name +toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts) +toHsPred (IParam n t) = HsIParam n (toLHsType t) toLHsType = noLoc . toHsType -toHsType :: Type -> GHC.HsType GHC.Name +toHsType :: Type -> HsType Name toHsType t = case t of - TyVarTy v -> GHC.HsTyVar (tyVarName v) - AppTy a b -> GHC.HsAppTy (toLHsType a) (toLHsType b) + TyVarTy v -> HsTyVar (tyVarName v) + AppTy a b -> 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) + [] -> HsTyVar (tyConName tc) + _ -> HsAppTy (tycon tc) (args ts) + FunTy a b -> HsFunTy (toLHsType a) (toLHsType b) ForAllTy v t -> cvForAll [v] t - PredTy p -> GHC.HsPredTy (toHsPred p) + PredTy p -> 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) - + tycon tc = noLoc (HsTyVar (tyConName tc)) + args ts = foldl1 (\a b -> noLoc $ 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 + cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) + tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs -- ----------------------------------------------------------------------------- -- A monad which collects error messages |