aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Main.hs109
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.