diff options
| -rw-r--r-- | src/Main.hs | 109 |
1 files changed, 90 insertions, 19 deletions
diff --git a/src/Main.hs b/src/Main.hs index aad43840..a87b5c15 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,8 +6,10 @@ -- Ported to use the GHC API by David Waern during "Summer of Code" 2006 -- + module Main (main) where + import Haddock.Html import Haddock.Hoogle import Haddock.Rename @@ -19,6 +21,7 @@ import Haddock.Exception import Haddock.Utils.GHC import Paths_haddock ( getDataDir ) + import Prelude hiding ( catch ) import Control.Exception import Control.Monad @@ -50,6 +53,7 @@ import Data.Map (Map) import Distribution.InstalledPackageInfo ( InstalledPackageInfo(..) ) import Distribution.Simple.Utils + import GHC import Outputable import SrcLoc @@ -76,13 +80,16 @@ import DynFlags hiding ( Option ) import Packages hiding ( package ) import StaticFlags ( parseStaticFlags ) + -------------------------------------------------------------------------------- -- Exception handling -------------------------------------------------------------------------------- + handleTopExceptions = handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions + handleNormalExceptions inner = handle (\exception -> do hFlush stdout @@ -96,12 +103,14 @@ handleNormalExceptions inner = exitFailure ) inner + handleHaddockExceptions inner = handleDyn (\(e::HaddockException) -> do putStrLn $ "haddock: " ++ (show e) exitFailure ) inner + handleGhcExceptions inner = -- compilation errors: messages with locations attached handleDyn (\dyn -> do @@ -121,10 +130,12 @@ handleGhcExceptions inner = exitFailure ) inner + -------------------------------------------------------------------------------- -- Top-level -------------------------------------------------------------------------------- + main :: IO () main = handleTopExceptions $ do args <- getArgs @@ -217,9 +228,11 @@ getUsePackages flags session = do 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. @@ -227,6 +240,7 @@ 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 @@ -238,6 +252,7 @@ parseGhcFlags session ghcFlags = do when (rest == ghcFlag) $ throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag)) return dynflags' + parseHaddockOpts :: [String] -> IO ([Flag], [String]) parseHaddockOpts words = @@ -247,9 +262,11 @@ parseHaddockOpts words = prog <- getProgramName throwE (concat errors ++ usageInfo (usageHeader prog) (options False)) + usageHeader :: String -> String usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" + data Flag = Flag_CSS String | Flag_Debug @@ -283,6 +300,7 @@ data Flag | Flag_GhcLibDir String deriving (Eq) + options :: Bool -> [OptDescr Flag] options backwardsCompat = [ @@ -350,10 +368,12 @@ options backwardsCompat = ++ "pass arguments to the flag)") ] + 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) @@ -516,6 +536,7 @@ run flags modules extEnv = do fs -> let filename = (last fs) in writeInterfaceFile filename iface + type CheckedMod = (Module, FilePath, FullyCheckedMod) type FullyCheckedMod = (ParsedSource, @@ -523,6 +544,7 @@ type FullyCheckedMod = (ParsedSource, TypecheckedSource, ModuleInfo) + -- | This data structure collects all the information we need about a home -- package module data ModuleDataGHC = ModuleDataGHC { @@ -538,6 +560,7 @@ data ModuleDataGHC = ModuleDataGHC { ghcInstances :: [Instance] } + -- | Dig out what we want from the GHC API without altering anything moduleDataGHC :: CheckedMod -> ModuleDataGHC moduleDataGHC (mod, file, checkedMod) = ModuleDataGHC { @@ -557,6 +580,7 @@ moduleDataGHC (mod, file, checkedMod) = ModuleDataGHC { (group, _, mbExports, mbDoc, info) = renamed (parsed, renamed, _, modInfo) = checkedMod + -- | Massage the data in ModuleDataGHC 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. @@ -622,6 +646,7 @@ pass1data modData flags modMap = do else opts 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 @@ -632,10 +657,12 @@ pass1 modules flags = foldM produceAndInsert Map.empty modules let key = ghcModule modData return (Map.insert key resultMod modMap) + sameName (DocEntity _) _ = False sameName (DeclEntity _) (DocEntity _) = False sameName (DeclEntity a) (DeclEntity b) = a == b + -- This map includes everything that can be exported separately, -- that means: top declarations, class methods and record selectors -- TODO: merge this with mkDeclMap and the extractXXX functions @@ -654,15 +681,19 @@ mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs) recordFieldDocs = [ (unLoc lname, doc) | ConDeclField lname _ (Just (L _ doc)) <- fields ] + -------------------------------------------------------------------------------- -- Source code entities -------------------------------------------------------------------------------- + data Entity = DocEntity (DocDecl Name) | DeclEntity Name data LEntity = Located Entity + sortByLoc = map unLoc . sortBy (comparing getLoc) + -- | Collect all the entities in a class that can be documented. -- The entities are sorted by their SrcLoc. collectClassEntities tcd = sortByLoc (docs ++ meths ++ sigs) @@ -676,6 +707,7 @@ collectClassEntities tcd = sortByLoc (docs ++ meths ++ sigs) let sigName = fromJust . sigNameNoLoc in [ L l (DeclEntity (sigName sig)) | L l sig <- tcdSigs tcd ] + -- | Collect all the entities in the source file that can be documented. -- The entities are sorted by their SrcLoc. collectEntities :: HsGroup Name -> [Entity] @@ -696,10 +728,12 @@ collectEntities group = sortByLoc (docs ++ declarations) forName (ForeignImport name _ _) = unLoc name forName (ForeignExport name _ _) = unLoc name + -- | Collect the docs and attach them to the right name collectDocs :: [Entity] -> [(Name, HsDoc Name)] collectDocs entities = collect Nothing DocEmpty entities + collect :: Maybe Entity -> HsDoc Name -> [Entity] -> [(Name, HsDoc Name)] collect d doc_so_far [] = case d of @@ -721,29 +755,35 @@ collect d doc_so_far (e:es) = | sameName d0 e -> collect d doc_so_far es | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) + finishedDoc :: Entity -> HsDoc Name -> [(Name, HsDoc Name)] -> [(Name, HsDoc Name)] finishedDoc d DocEmpty rest = rest finishedDoc (DeclEntity name) doc rest = (name, doc) : rest finishedDoc _ _ rest = rest --------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- + allSubNames :: HsGroup Name -> [Name] allSubNames group = concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ] + mkSubMap :: HsGroup Name -> Map Name [Name] mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group, let name:subs = map unLoc (tyClDeclNames tycld) ] + 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 :: [Entity] -> [Name] entityNames entities = [ name | DeclEntity name <- entities ] {- @@ -759,6 +799,8 @@ getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of 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), @@ -805,12 +847,14 @@ getDeclFromGroup group name = matching = [ for | for <- lfors, forName (unLoc for) == name ] forName (ForeignExport n _ _) = unLoc n forName (ForeignImport n _ _) = unLoc n + parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = case break (==',') s of (fpath,',':file) -> (fpath,file) (file, _) -> ("", file) + updateHTMLXRefs :: [HaddockPackage] -> IO () updateHTMLXRefs packages = do @@ -819,6 +863,7 @@ updateHTMLXRefs packages = do mapping = [ (mod, html) | (HaddockPackage mods _ html) <- packages, mod <- mods ] + getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) getPrologue flags = case [filename | Flag_Prologue filename <- flags ] of @@ -830,8 +875,11 @@ getPrologue flags Right doc -> return (Just doc) _otherwise -> throwE "multiple -p/--prologue options" --- ----------------------------------------------------------------------------- + +------------------------------------------------------------------------------- -- Phase 2 +------------------------------------------------------------------------------- + renameModule :: Map Name Name -> HaddockModule -> ErrMsgM HaddockModule renameModule renamingEnv mod = @@ -878,11 +926,10 @@ renameModule renamingEnv mod = hmod_rn_doc_map = rnDocMap, hmod_rn_export_items = renamedExportItems } --- ----------------------------------------------------------------------------- --- Build the list of items that will become the documentation, from the + +-- | 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 -> Module -- this module @@ -957,6 +1004,7 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m where m = nameModule n + fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) -> Map Name (HsDoc Name) -> [ExportItem Name] fullContentsOfThisModule module_ entities declMap docMap @@ -967,11 +1015,11 @@ fullContentsOfThisModule module_ entities declMap docMap where mkExport decl = ExportDecl name decl (Map.lookup name docMap) [] mkExportItem _ = Nothing --- Sometimes the declaration we want to export is not the "main" declaration: + +-- | 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 :: Name -> Module -> LHsDecl Name -> LHsDecl Name extractDecl name mdl decl | Just n <- getMainDeclBinder (unLoc decl), n == name = decl @@ -992,12 +1040,15 @@ extractDecl name mdl decl where name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d)) + toTypeNoLoc :: Located Name -> LHsType Name toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname)) + rmLoc :: Located a -> Located a rmLoc a = noLoc (unLoc a) + 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) -> @@ -1009,6 +1060,7 @@ extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl" + extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" @@ -1022,17 +1074,15 @@ extractRecSel nm mdl t tvs (L _ con : rest) = matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ] data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- ----------------------------------------------------------------------------- --- Pruning +-- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items where hasDoc (ExportDecl _ _ d _) = isJust d hasDoc _ = True --- ----------------------------------------------------------------------------- --- Gather a list of original names exported from this module +-- | Gather a list of original names exported from this module mkVisibleNames :: Module -> ModuleMap -> [Name] @@ -1079,11 +1129,13 @@ mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap _ -> return [] + exportModuleMissingErr this mdl = ["Warning: in export list of " ++ show (moduleString this) ++ ": module not found: " ++ show (moduleString mdl)] --- for a given entity, find all the names it "owns" (ie. all the + +-- | 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 :: ModuleMap -> Name -> [Name] @@ -1094,6 +1146,7 @@ allSubsOfName mod_map name Nothing -> [] | otherwise = error $ "Main.allSubsOfName: unexpected unqual'd name" + -- | 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 @@ -1121,7 +1174,7 @@ buildGlobalDocEnv modules n (nameSetMod n modName) env keep_new env n = Map.insert n (nameSetMod n modName) env --- ----------------------------------------------------------------------------- + -- Named documentation findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name)) @@ -1134,7 +1187,7 @@ findNamedDoc name entities = search entities | otherwise = search rest search (_other_decl : rest) = search rest --- ----------------------------------------------------------------------------- + -- Haddock options embedded in the source file processOptions_ str = let (opts, msg) = runWriter (processOptions str) @@ -1151,6 +1204,7 @@ processOptions str = do | all isSpace this -> return [] | otherwise -> do opt <- parseOption this; return (maybeToList opt) + parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) parseOption "prune" = return (Just OptPrune) @@ -1158,10 +1212,12 @@ parseOption "ignore-exports" = return (Just OptIgnoreExports) parseOption "not-home" = return (Just OptNotHome) parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing --- simplified type for sorting types, ignoring qualification (not visible + +-- | Simplified type for sorting types, ignoring qualification (not visible -- in Haddock output) and unifying special tycons with normal ones. data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) + attachInstances :: [HaddockModule] -> [HaddockModule] attachInstances modules = map attach modules where @@ -1176,6 +1232,7 @@ attachInstances modules = map attach modules Just instheads -> instheads) attachExport otherExport = otherExport + collectInstances :: [HaddockModule] -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances @@ -1190,6 +1247,7 @@ collectInstances modules tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] + instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args) @@ -1211,11 +1269,13 @@ instHead (_, _, cls, args) 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 + funTyConName = mkWiredInName gHC_PRIM (mkOccNameFS tcName FSLIT("(->)")) funTyConKey @@ -1226,15 +1286,19 @@ funTyConName = mkWiredInName gHC_PRIM toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) + -------------------------------------------------------------------------------- -- Type -> HsType conversion -------------------------------------------------------------------------------- + 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 -> HsType Name toHsType t = case t of @@ -1254,12 +1318,13 @@ toHsType t = case t of cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t) tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs --- ----------------------------------------------------------------------------- + -- A monad which collects error messages type ErrMsg = String type ErrMsgM a = Writer [ErrMsg] a + -------------------------------------------------------------------------------- -- Packages -------------------------------------------------------------------------------- @@ -1272,6 +1337,7 @@ data HaddockPackage = HaddockPackage { pdHtmlPath :: FilePath } + -- | Recreate exposed modules from an InstalledPackageInfo packageModules :: InstalledPackageInfo -> [Module] packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames @@ -1279,6 +1345,7 @@ packageModules pkgInfo = map (mkModule (pkgId pkgInfo)) moduleNames moduleNames = map mkModuleName (exposedModules pkgInfo) pkgId = mkPackageId . package + -- | Get the Haddock HTML directory path for a package getHtml :: InstalledPackageInfo -> IO FilePath getHtml pkgInfo = case haddockHTMLs pkgInfo of @@ -1288,6 +1355,7 @@ getHtml pkgInfo = case haddockHTMLs pkgInfo of "HTML directory " ++ path ++ " does not exist." _ -> throwE "No Haddock documentation installed." + -- | Get the Haddock interface path for a package getIface :: InstalledPackageInfo -> IO FilePath getIface pkgInfo = case haddockInterfaces pkgInfo of @@ -1297,6 +1365,7 @@ getIface pkgInfo = case haddockInterfaces pkgInfo of "Interface file " ++ file ++ " does not exist." _ -> throwE "No Haddock interface installed." + -- | Try to create a HaddockPackage structure for a package getPackage :: Session -> InstalledPackageInfo -> IO HaddockPackage getPackage session pkgInfo = do @@ -1313,6 +1382,7 @@ getPackage session pkgInfo = do pdDocEnv = docEnv, pdHtmlPath = html } + -- | Try to create a HaddockPackage for each package in the session except for -- rts. Print a warning on stdout if a HaddockPackage could not be created. @@ -1338,6 +1408,7 @@ getPackages session packages = do return Nothing ) + -- | Build one big doc env out of a list of packages. If multiple packages -- export the same (original) name, we just pick one of the packages as the -- documentation site. |