diff options
| -rw-r--r-- | haddock.cabal | 1 | ||||
| -rw-r--r-- | src/Haddock/Html.hs | 3 | ||||
| -rw-r--r-- | src/Haddock/Typecheck.hs | 123 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 15 | ||||
| -rw-r--r-- | src/Haddock/Utils/GHC.hs | 51 | ||||
| -rw-r--r-- | src/Main.hs | 288 |
6 files changed, 269 insertions, 212 deletions
diff --git a/haddock.cabal b/haddock.cabal index 87881708..8a8496b5 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -94,4 +94,5 @@ other-modules: Haddock.InterfaceFile Haddock.Exception Haddock.Options + Haddock.Typecheck Main diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs index 79a2625f..74aa4e34 100644 --- a/src/Haddock/Html.hs +++ b/src/Haddock/Html.hs @@ -17,8 +17,9 @@ import Haddock.HH import Haddock.HH2 import Haddock.ModuleTree import Haddock.Types -import Haddock.Utils import Haddock.Version +import Haddock.Utils +import Haddock.Utils.GHC import Haddock.Utils.Html import qualified Haddock.Utils.Html as Html diff --git a/src/Haddock/Typecheck.hs b/src/Haddock/Typecheck.hs new file mode 100644 index 00000000..088ee8a1 --- /dev/null +++ b/src/Haddock/Typecheck.hs @@ -0,0 +1,123 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + + +module Haddock.Typecheck ( + GhcModule(..), + typecheckFiles +) where + + +import Haddock.Exception +import Haddock.Utils.GHC + + +import Data.Maybe +import Control.Monad +import GHC +import Digraph +import BasicTypes +import SrcLoc + + +-- | This data structure collects all the information we want about a home +-- package module that we can get from GHC's typechecker +data GhcModule = GhcModule { + ghcModule :: Module, + ghcFilename :: FilePath, + ghcMbDocOpts :: Maybe String, + ghcHaddockModInfo :: HaddockModInfo Name, + ghcMbDoc :: Maybe (HsDoc Name), + ghcGroup :: HsGroup Name, + ghcMbExports :: Maybe [LIE Name], + ghcExportedNames :: [Name], + ghcNamesInScope :: [Name], + ghcInstances :: [Instance] +} + + +typecheckFiles :: Session -> [FilePath] -> IO [GhcModule] +typecheckFiles session files = do + checkedMods <- sortAndCheckModules session files + return (map mkGhcModule checkedMods) + + +-- | Get the sorted graph of all loaded modules and their dependencies +getSortedModuleGraph :: Session -> IO [(Module, FilePath)] +getSortedModuleGraph session = do + mbModGraph <- depanal session [] True + moduleGraph <- case mbModGraph of + Just mg -> return mg + Nothing -> throwE "Failed to load all modules" + let + getModFile = fromJust . ml_hs_file . ms_location + sortedGraph = topSortModuleGraph False moduleGraph Nothing + sortedModules = concatMap flattenSCC sortedGraph + modsAndFiles = [ (ms_mod modsum, getModFile modsum) | + modsum <- sortedModules ] + return modsAndFiles + + +type CheckedMod = (Module, FilePath, FullyCheckedMod) + + +type FullyCheckedMod = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo) + + +-- TODO: make it handle cleanup +sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod] +sortAndCheckModules session files = do + + -- load all argument files + + targets <- mapM (\f -> guessTarget f Nothing) files + setTargets session targets + + -- compute the dependencies and load them as well + + allMods <- getSortedModuleGraph session + targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods + setTargets session targets' + + flag <- load session LoadAllTargets + when (failed flag) $ + throwE "Failed to load all needed modules" + + -- typecheck the argument modules + + let argMods = filter ((`elem` files) . snd) allMods + + checkedMods <- forM argMods $ \(mod, file) -> do + mbMod <- checkModule session (moduleName mod) False + case mbMod of + Just (CheckedModule a (Just b) (Just c) (Just d) _) + -> return (mod, file, (a,b,c,d)) + _ -> throwE ("Failed to check module: " ++ moduleString mod) + + return checkedMods + + +-- | Dig out what we want from the typechecker output +mkGhcModule :: CheckedMod -> GhcModule +mkGhcModule (mod, file, checkedMod) = GhcModule { + ghcModule = mod, + ghcFilename = file, + ghcMbDocOpts = mbOpts, + ghcHaddockModInfo = info, + ghcMbDoc = mbDoc, + ghcGroup = group, + ghcMbExports = mbExports, + ghcExportedNames = modInfoExports modInfo, + ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, + ghcInstances = modInfoInstances modInfo +} + where + HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed + (group, _, mbExports, mbDoc, info) = renamed + (parsed, renamed, _, modInfo) = checkedMod diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index a7f5f8a9..52618c30 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -20,8 +20,7 @@ module Haddock.Utils ( -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg, - + -- * HTML cross reference mapping html_xrefs_ref, @@ -231,18 +230,6 @@ escapeStr = flip escapeString unreserved escapeStr = escapeURIString isUnreserved #endif --- there should be a better way to check this using the GHC API -isConSym n = head (nameOccString n) == ':' -isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar - where fstChar = head (nameOccString n) - -nameOccString = occNameString . nameOccName - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - -mkModuleNoPkg :: String -> Module -mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) ----------------------------------------------------------------------------- -- HTML cross references diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs index 8393cbb2..3ac90d77 100644 --- a/src/Haddock/Utils/GHC.hs +++ b/src/Haddock/Utils/GHC.hs @@ -4,9 +4,12 @@ -- (c) Simon Marlow 2003 -- + module Haddock.Utils.GHC where + import Debug.Trace +import Data.Char import GHC import HsSyn @@ -17,6 +20,42 @@ import Packages import UniqFM import Name + +-- names + +nameOccString = occNameString . nameOccName + + +nameSetMod n newMod = + mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n) + + +nameSetPkg pkgId n = + mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod)) + (nameOccName n) (nameSrcSpan n) + where mod = nameModule n + + +-- modules + + +moduleString :: Module -> String +moduleString = moduleNameString . moduleName + + +mkModuleNoPkg :: String -> Module +mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) + + +-- misc + + +-- there should be a better way to check this using the GHC API +isConSym n = head (nameOccString n) == ':' +isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar + where fstChar = head (nameOccString n) + + getMainDeclBinder :: HsDecl name -> Maybe name getMainDeclBinder (TyClD d) = Just (tcdName d) getMainDeclBinder (ValD d) @@ -28,18 +67,10 @@ getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing getMainDeclBinder _ = Nothing + -- To keep if if minf_iface is re-introduced --modInfoName = moduleName . mi_module . minf_iface --modInfoMod = mi_module . minf_iface -trace_ppr x y = trace (showSDoc (ppr x)) y --- names - -nameSetMod n newMod = - mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n) - -nameSetPkg pkgId n = - mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod)) - (nameOccName n) (nameSrcSpan n) - where mod = nameModule n +trace_ppr x y = trace (showSDoc (ppr x)) y diff --git a/src/Main.hs b/src/Main.hs index 7223b8f6..e7b52e4d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Exception import Haddock.Options +import Haddock.Typecheck import Haddock.Utils.GHC import Paths_haddock @@ -55,7 +56,6 @@ import Distribution.Simple.Utils import GHC import Outputable import SrcLoc -import Digraph import Name import Module import InstEnv @@ -68,7 +68,6 @@ import Bag import HscTypes import Util (handleDyn) import ErrUtils (printBagOfErrors) -import BasicTypes import UniqFM import FastString @@ -129,9 +128,9 @@ handleGhcExceptions inner = ) inner --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Top-level --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- main :: IO () @@ -165,7 +164,7 @@ main = handleTopExceptions $ do packages <- getPackages session exposedPackages -- typechecking - modules <- sortAndCheckModules session fileArgs + modules <- typecheckFiles session fileArgs -- update the html references for rendering phase (global variable) updateHTMLXRefs packages @@ -177,84 +176,6 @@ main = handleTopExceptions $ do run flags modules env -handleFlags flags fileArgs = do - usage <- getUsage - - when (Flag_Help `elem` flags) (bye usage) - when (Flag_Version `elem` flags) byeVersion - when (null fileArgs) (bye usage) - - let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> throwE "no GHC lib dir specified" - xs -> last xs - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - throwE ("-h cannot be used with --gen-index or --gen-contents") - - return ghcLibDir - - --- | Handle the -use-package flags --- --- Returns the names of the packages (without version number), if parsing --- succeeded. --- --- It would be better to try to get the "exposed" packages from GHC instead. --- This would make the -use-package flag unnecessary. But currently it --- seems all you can get from the GHC api is all packages that are linked in --- (i.e the closure of the exposed packages). -getUsePackages :: [Flag] -> Session -> IO [String] -getUsePackages flags session = do - - -- get the packages from the commandline flags - let packages = [ pkg | Flag_UsePackage pkg <- flags ] - - -- expose these packages - -- (makes "-use-package pkg" equal to "-g '-package pkg'") - - dfs <- getSessionDynFlags session - let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages } - setSessionDynFlags session dfs' - - -- try to parse these packages into PackageIndentifiers - - mapM (handleParse . unpackPackageId . stringToPackageId) packages - where - handleParse (Just pkg) = return (pkgName pkg) - handleParse Nothing = throwE "Could not parse package identifier" - - -------------------------------------------------------------------------------- --- Flags -------------------------------------------------------------------------------- - - --- | Filter out the GHC specific flags and try to parse and set them as static --- flags. Return a list of flags that couldn't be parsed. -tryParseStaticFlags flags = do - let ghcFlags = [ str | Flag_GhcFlag str <- flags ] - parseStaticFlags ghcFlags - - --- | Try to parse dynamic GHC flags -parseGhcFlags session ghcFlags = do - dflags <- getSessionDynFlags session - foldlM parseFlag dflags (map words ghcFlags) - where - -- try to parse a flag as either a dynamic or static GHC flag - parseFlag dynflags ghcFlag = do - (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag - when (rest == ghcFlag) $ - throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) - return dynflags' - - -byeVersion = - bye ("Haddock version " ++ projectVersion ++ - ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n") - - startGHC :: String -> IO (Session, DynFlags) startGHC libDir = do session <- newSession (Just libDir) @@ -268,57 +189,8 @@ startGHC libDir = do setSessionDynFlags session flags'' return (session, flags'') - --- | Get the sorted graph of all loaded modules and their dependencies -getSortedModuleGraph :: Session -> IO [(Module, FilePath)] -getSortedModuleGraph session = do - mbModGraph <- depanal session [] True - moduleGraph <- case mbModGraph of - Just mg -> return mg - Nothing -> throwE "Failed to load all modules" - let - getModFile = fromJust . ml_hs_file . ms_location - sortedGraph = topSortModuleGraph False moduleGraph Nothing - sortedModules = concatMap flattenSCC sortedGraph - modsAndFiles = [ (ms_mod modsum, getModFile modsum) | - modsum <- sortedModules ] - return modsAndFiles - - --- TODO: make it handle cleanup -sortAndCheckModules :: Session -> [FilePath] -> IO [CheckedMod] -sortAndCheckModules session files = do - - -- load all argument files - - targets <- mapM (\f -> guessTarget f Nothing) files - setTargets session targets - - -- compute the dependencies and load them as well - - allMods <- getSortedModuleGraph session - targets' <- mapM (\(_, f) -> guessTarget f Nothing) allMods - setTargets session targets' - - flag <- load session LoadAllTargets - when (failed flag) $ - throwE "Failed to load all needed modules" - - -- typecheck the argument modules - - let argMods = filter ((`elem` files) . snd) allMods - - checkedMods <- forM argMods $ \(mod, file) -> do - mbMod <- checkModule session (moduleName mod) False - case mbMod of - Just (CheckedModule a (Just b) (Just c) (Just d) _) - -> return (mod, file, (a,b,c,d)) - _ -> throwE ("Failed to check module: " ++ moduleString mod) - - return checkedMods - - -run :: [Flag] -> [CheckedMod] -> Map Name Name -> IO () + +run :: [Flag] -> [GhcModule] -> Map Name Name -> IO () run flags modules extEnv = do let title = case [str | Flag_Heading str <- flags] of @@ -366,12 +238,10 @@ run flags modules extEnv = do prologue <- getPrologue flags let - -- collect the data from GHC that we need for each home module - ghcModuleData = map moduleDataGHC modules -- run pass 1 on this data - (modMap, messages) = runWriter (pass1 ghcModuleData flags) + (modMap, messages) = runWriter (pass1 modules flags) - haddockMods = catMaybes [ Map.lookup mod modMap | (mod,_,_) <- modules ] + haddockMods = catMaybes [ Map.lookup (ghcModule m) modMap | m <- modules ] homeEnv = buildGlobalDocEnv haddockMods env = homeEnv `Map.union` extEnv haddockMods' = attachInstances haddockMods @@ -418,55 +288,105 @@ run flags modules extEnv = do writeInterfaceFile filename iface -type CheckedMod = (Module, FilePath, FullyCheckedMod) +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + -type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo) +handleFlags flags fileArgs = do + usage <- getUsage + when (Flag_Help `elem` flags) (bye usage) + when (Flag_Version `elem` flags) byeVersion + when (null fileArgs) (bye usage) --- | This data structure collects all the information we need about a home --- package module -data ModuleDataGHC = ModuleDataGHC { - ghcModule :: Module, - ghcFilename :: FilePath, - ghcMbDocOpts :: Maybe String, - ghcHaddockModInfo :: HaddockModInfo Name, - ghcMbDoc :: Maybe (HsDoc Name), - ghcGroup :: HsGroup Name, - ghcMbExports :: Maybe [LIE Name], - ghcExportedNames :: [Name], - ghcNamesInScope :: [Name], - ghcInstances :: [Instance] -} + let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> throwE "no GHC lib dir specified" + xs -> last xs + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + throwE ("-h cannot be used with --gen-index or --gen-contents") --- | Dig out what we want from the GHC API without altering anything -moduleDataGHC :: CheckedMod -> ModuleDataGHC -moduleDataGHC (mod, file, checkedMod) = ModuleDataGHC { - ghcModule = mod, - ghcFilename = file, - ghcMbDocOpts = mbOpts, - ghcHaddockModInfo = info, - ghcMbDoc = mbDoc, - ghcGroup = group, - ghcMbExports = mbExports, - ghcExportedNames = modInfoExports modInfo, - ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, - ghcInstances = modInfoInstances modInfo -} + return ghcLibDir + + +-- | Handle the -use-package flags +-- +-- Returns the names of the packages (without version number), if parsing +-- succeeded. +-- +-- It would be better to try to get the "exposed" packages from GHC instead. +-- This would make the -use-package flag unnecessary. But currently it +-- seems all you can get from the GHC api is all packages that are linked in +-- (i.e the closure of the exposed packages). +getUsePackages :: [Flag] -> Session -> IO [String] +getUsePackages flags session = do + + -- get the packages from the commandline flags + let packages = [ pkg | Flag_UsePackage pkg <- flags ] + + -- expose these packages + -- (makes "-use-package pkg" equal to "-g '-package pkg'") + + dfs <- getSessionDynFlags session + let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage packages } + setSessionDynFlags session dfs' + + -- try to parse these packages into PackageIndentifiers + + mapM (handleParse . unpackPackageId . stringToPackageId) packages where - HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed - (group, _, mbExports, mbDoc, info) = renamed - (parsed, renamed, _, modInfo) = checkedMod + handleParse (Just pkg) = return (pkgName pkg) + handleParse Nothing = throwE "Could not parse package identifier" --- | Massage the data in ModuleDataGHC to produce something closer to what +-- | Filter out the GHC specific flags and try to parse and set them as static +-- flags. Return a list of flags that couldn't be parsed. +tryParseStaticFlags flags = do + let ghcFlags = [ str | Flag_GhcFlag str <- flags ] + parseStaticFlags ghcFlags + + +-- | Try to parse dynamic GHC flags +parseGhcFlags session ghcFlags = do + dflags <- getSessionDynFlags session + foldlM parseFlag dflags (map words ghcFlags) + where + -- try to parse a flag as either a dynamic or static GHC flag + parseFlag dynflags ghcFlag = do + (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag + when (rest == ghcFlag) $ + throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) + return dynflags' + + +byeVersion = + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n") + + +------------------------------------------------------------------------------- +-- Phase 1 +------------------------------------------------------------------------------- + + +-- | Produce a map of HaddockModules with information that is close to +-- renderable. What is lacking after this pass are the renamed export items. +pass1 :: [GhcModule] -> [Flag] -> ErrMsgM ModuleMap +pass1 modules flags = foldM produceAndInsert Map.empty modules + where + produceAndInsert modMap modData = do + resultMod <- pass1data modData flags modMap + let key = ghcModule modData + return (Map.insert key resultMod modMap) + + +-- | Massage the data in GhcModule to produce something closer to what -- we want to render. To do this, we need access to modules before this one -- in the topological sort, to which we have already done this conversion. -- That's what's in the ModuleMap. -pass1data :: ModuleDataGHC -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule +pass1data :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM HaddockModule pass1data modData flags modMap = do let mod = ghcModule modData @@ -528,17 +448,6 @@ pass1data modData flags modMap = do return opts' --- | Produce a map of HaddockModules with information that is close to --- renderable. What is lacking after this pass are the renamed export items. -pass1 :: [ModuleDataGHC] -> [Flag] -> ErrMsgM ModuleMap -pass1 modules flags = foldM produceAndInsert Map.empty modules - where - produceAndInsert modMap modData = do - resultMod <- pass1data modData flags modMap - let key = ghcModule modData - return (Map.insert key resultMod modMap) - - sameName (DocEntity _) _ = False sameName (DeclEntity _) (DocEntity _) = False sameName (DeclEntity a) (DeclEntity b) = a == b @@ -610,6 +519,11 @@ collectEntities group = sortByLoc (docs ++ declarations) forName (ForeignExport name _ _) = unLoc name +-------------------------------------------------------------------------------- +-- Collect docs +-------------------------------------------------------------------------------- + + -- | Collect the docs and attach them to the right name collectDocs :: [Entity] -> [(Name, HsDoc Name)] collectDocs entities = collect Nothing DocEmpty entities |