aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface/Create.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface/Create.hs')
-rw-r--r--src/Haddock/Interface/Create.hs578
1 files changed, 578 insertions, 0 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
new file mode 100644
index 00000000..161b2851
--- /dev/null
+++ b/src/Haddock/Interface/Create.hs
@@ -0,0 +1,578 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+
+module Haddock.Interface.Create (createInterface) where
+
+
+import Haddock.Types
+import Haddock.Options
+import Haddock.GHC.Utils
+import Haddock.Utils
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List
+import Data.Maybe
+import Data.Char
+import Data.Ord
+import Control.Monad.Writer
+
+import GHC
+import Outputable
+import SrcLoc
+import Name
+import Module
+import InstEnv
+import Class
+import TypeRep
+import Var hiding (varName)
+import TyCon
+import PrelNames
+import Bag
+import HscTypes
+import Util (handleDyn)
+import ErrUtils (printBagOfErrors)
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+type LookupMod = (Module -> Maybe Interface)
+
+
+-- | Process the data in the GhcModule to produce an interface.
+-- To do this, we need access to already processed modules in the topological
+-- sort. That's what's in the module map.
+createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface
+createInterface ghcMod flags modMap = do
+
+ let mod = ghcModule ghcMod
+
+ opts <- mkDocOpts (ghcMbDocOpts ghcMod) flags mod
+
+ let group = ghcGroup ghcMod
+ entities = (nubBy sameName . getTopEntities) group
+ exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
+ entityNames_ = entityNames entities
+ subNames = allSubNames group
+ localNames = entityNames_ ++ subNames
+ subMap = mkSubMap group
+ expDeclMap = mkDeclMap (ghcExportedNames ghcMod) group
+ localDeclMap = mkDeclMap entityNames_ group
+ docMap = mkDocMap group
+ ignoreExps = Flag_IgnoreAllExports `elem` flags
+ lookupMod m = Map.lookup mod modMap
+
+ visibleNames <- mkVisibleNames mod lookupMod localNames
+ (ghcNamesInScope ghcMod)
+ subMap exports opts localDeclMap
+
+ exportItems <- mkExportItems lookupMod mod (ghcExportedNames ghcMod)
+ expDeclMap localDeclMap subMap entities
+ opts exports ignoreExps docMap
+
+ -- prune the export list to just those declarations that have
+ -- documentation, if the 'prune' option is on.
+ let
+ prunedExportItems
+ | OptPrune `elem` opts = pruneExportItems exportItems
+ | otherwise = exportItems
+
+ return Interface {
+ hmod_mod = mod,
+ hmod_orig_filename = ghcFilename ghcMod,
+ hmod_info = ghcHaddockModInfo ghcMod,
+ hmod_doc = ghcMbDoc ghcMod,
+ 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 = ghcExportedNames ghcMod,
+ hmod_visible_exports = visibleNames,
+ hmod_exported_decl_map = expDeclMap,
+ hmod_instances = ghcInstances ghcMod
+ }
+
+
+-------------------------------------------------------------------------------
+-- Doc options
+--
+-- Haddock options that are embedded in the source file
+-------------------------------------------------------------------------------
+
+
+mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts mbOpts flags mod = do
+ opts <- case mbOpts of
+ Just opts -> processOptions opts
+ Nothing -> return []
+ let opts' = if Flag_HideModule (moduleString mod) `elem` flags
+ then OptHide : opts
+ else opts
+ return opts'
+
+
+processOptions_ str = let (opts, msg) = runWriter (processOptions str)
+ in print msg >> return opts
+
+
+processOptions :: String -> ErrMsgM [DocOption]
+processOptions str = do
+ case break (== ',') str of
+ (this, ',':rest) -> do
+ opt <- parseOption this
+ opts <- processOptions rest
+ return (maybeToList opt ++ opts)
+ (this, _)
+ | 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)
+parseOption "ignore-exports" = return (Just OptIgnoreExports)
+parseOption "not-home" = return (Just OptNotHome)
+parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
+
+
+--------------------------------------------------------------------------------
+-- Source code entities
+--
+-- An entity is a Haskell declaration or a Haddock comment. We need to extract
+-- entities out of classes and top levels since we need them in the interface.
+--------------------------------------------------------------------------------
+
+
+data Entity = DocEntity (DocDecl Name) | DeclEntity Name
+data LEntity = Located Entity
+
+sameName (DocEntity _) _ = False
+sameName (DeclEntity _) (DocEntity _) = False
+sameName (DeclEntity a) (DeclEntity b) = a == b
+
+
+sortByLoc = map unLoc . sortBy (comparing getLoc)
+
+
+-- | Get all the entities in a class. The entities are sorted by their
+-- SrcLoc.
+getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)
+ where
+ docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]
+ meths =
+ let bindings = bagToList (tcdMeths tcd)
+ bindingName = unLoc . fun_id
+ in [ L l (DeclEntity (bindingName b)) | L l b <- bindings ]
+ sigs =
+ let sigName = fromJust . sigNameNoLoc
+ in [ L l (DeclEntity (sigName sig)) | L l sig <- tcdSigs tcd ]
+
+
+-- | Get all the top level entities in a module. The entities are sorted by
+-- their SrcLoc.
+getTopEntities :: HsGroup Name -> [Entity]
+getTopEntities group = sortByLoc (docs ++ declarations)
+ where
+ docs = [ L l (DocEntity d) | L l d <- hs_docs group ]
+
+ declarations = [ L l (DeclEntity n) | (l, n) <- valds ++ tyclds ++ fords ]
+ where
+ valds = let ValBindsOut _ sigs = hs_valds group
+ -- we just use the sigs here for now.
+ -- TODO: collect from the bindings as well
+ -- (needed for docs to work for inferred entities)
+ in [ (l, fromJust (sigNameNoLoc s)) | L l s <- sigs ]
+ tyclds = [ (l, tcdName t) | L l t <- hs_tyclds group ]
+ fords = [ (l, forName f) | L l f <- hs_fords group ]
+ where
+ forName (ForeignImport name _ _) = unLoc name
+ forName (ForeignExport name _ _) = unLoc name
+
+
+--------------------------------------------------------------------------------
+-- Collect docs
+--
+-- To be able to attach the right Haddock comment to the right declaration,
+-- we sort the entities by their SrcLoc and "collect" the docs for each
+-- declaration.
+--------------------------------------------------------------------------------
+
+
+-- | 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
+ Nothing -> []
+ Just d0 -> finishedDoc d0 doc_so_far []
+
+collect d doc_so_far (e:es) =
+ case e of
+ DocEntity (DocCommentNext str) ->
+ case d of
+ Nothing -> collect d (docAppend doc_so_far str) es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+
+ DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es
+
+ _ -> case d of
+ Nothing -> collect (Just e) doc_so_far es
+ Just d0
+ | 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
+
+
+-------------------------------------------------------------------------------
+--
+-------------------------------------------------------------------------------
+
+
+-- 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
+mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)
+mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)
+ where
+ tyclds = map unLoc (hs_tyclds group)
+ classes = filter isClassDecl tyclds
+ datadecls = filter isDataDecl tyclds
+ constrs = [ con | d <- datadecls, L _ con <- tcdCons d ]
+ fields = concat [ fields | RecCon fields <- map con_details constrs]
+
+ topDeclDocs = collectDocs (getTopEntities group)
+ classMethDocs = concatMap (collectDocs . getClassEntities) classes
+
+ recordFieldDocs = [ (unLoc lname, doc) |
+ ConDeclField lname _ (Just (L _ doc)) <- fields ]
+
+
+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 ]
+{-
+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
+ 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 = 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) (TyClD (unLoc ltycl)))
+ _ -> Nothing
+ where
+ matching = [ ltycl | ltycl <- ltycls,
+ name `elem` map unLoc (tyClDeclNames (unLoc ltycl))]
+
+ getDeclFromFors lfors = case matching of
+ [for] -> Just (L (getLoc for) (ForD (unLoc for)))
+ _ -> Nothing
+ where
+ matching = [ for | for <- lfors, forName (unLoc for) == name ]
+ forName (ForeignExport n _ _) = unLoc n
+ forName (ForeignImport n _ _) = unLoc n
+
+
+-- | 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
+ :: LookupMod
+ -> 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
+ -> [Entity] -- entities in the current module
+ -> [DocOption]
+ -> Maybe [IE Name]
+ -> Bool -- --ignore-all-exports flag
+ -> Map Name (HsDoc Name)
+ -> ErrMsgM [ExportItem Name]
+
+mkExportItems lookupMod this_mod exported_names exportedDeclMap localDeclMap sub_map entities
+ opts maybe_exps ignore_all_exports docMap
+ | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
+ = everything_local_exported
+ | Just specs <- maybe_exps = do
+ exps <- mapM lookupExport specs
+ return (concat exps)
+ where
+ everything_local_exported = -- everything exported
+ return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
+
+ packageId = modulePackageId this_mod
+
+ 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 (mkModule packageId m)
+ lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
+ lookupExport (IEDoc doc) = return [ ExportDoc doc ]
+ lookupExport (IEDocNamed str)
+ = do r <- findNamedDoc str entities
+ case r of
+ Nothing -> return []
+ Just found -> return [ ExportDoc found ]
+
+ declWith :: Name -> ErrMsgM [ ExportItem Name ]
+ declWith t
+ | (Just decl, maybeDoc) <- findDecl t
+ = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
+ | otherwise
+ = return []
+ where
+ mdl = nameModule t
+ subs = filter (`elem` exported_names) all_subs
+ all_subs | mdl == this_mod = Map.findWithDefault [] t sub_map
+ | otherwise = allSubsOfName lookupMod t
+
+ fullContentsOf m
+ | m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)
+ | otherwise =
+ case lookupMod m of
+ Just hmod
+ | OptHide `elem` hmod_options hmod
+ -> return (hmod_export_items hmod)
+ | otherwise -> return [ ExportModule m ]
+ Nothing -> return [] -- already emitted a warning in visibleNames
+
+ 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)
+ | otherwise =
+ case lookupMod m of
+ Just hmod -> (Map.lookup n (hmod_exported_decl_map hmod),
+ Map.lookup n (hmod_doc_map hmod))
+ Nothing -> (Nothing, Nothing)
+ where
+ m = nameModule n
+
+
+fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) ->
+ Map Name (HsDoc Name) -> [ExportItem Name]
+fullContentsOfThisModule module_ entities declMap docMap
+ = catMaybes (map mkExportItem entities)
+ where
+ mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup lev "" doc)
+ mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap)
+ where mkExport decl = ExportDecl name decl (Map.lookup name docMap) []
+ mkExportItem _ = Nothing
+
+
+-- | 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
+ | otherwise =
+ case unLoc decl of
+ 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 (SigD sig)
+ _ -> error "internal: extractDecl"
+ TyClD d | isDataDecl d ->
+ let (n, tyvar_names) = name_and_tyvars d
+ 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 (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) ->
+ 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 (HsClassP c (map toTypeNoLoc tvs0))] ++ preds
+
+extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"
+
+
+extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]
+ -> LSig Name
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+
+extractRecSel nm mdl t tvs (L _ con : rest) =
+ case con_details con of
+ RecCon fields | (ConDeclField 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@(ConDeclField n _ _) <- flds, (unLoc n) == nm ]
+ data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
+
+
+-- 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
+mkVisibleNames :: Module
+ -> LookupMod
+ -> [Name]
+ -> [Name]
+ -> Map Name [Name]
+ -> Maybe [IE Name]
+ -> [DocOption]
+ -> Map Name (LHsDecl Name)
+ -> ErrMsgM [Name]
+
+mkVisibleNames mdl lookupMod localNames scope subMap maybeExps opts declMap
+ -- if no export list, just return all local names
+ | Nothing <- maybeExps = return (filter hasDecl localNames)
+ | OptIgnoreExports `elem` opts = return localNames
+ | Just expspecs <- maybeExps = do
+ visibleNames <- mapM extract expspecs
+ return $ filter isNotPackageName (concat visibleNames)
+ where
+ hasDecl name = isJust (Map.lookup name declMap)
+ isNotPackageName name = nameMod == mdl || isJust (lookupMod nameMod)
+ where nameMod = nameModule name
+
+ extract e =
+ case e of
+ 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 lookupMod t
+
+ IEThingWith t cs -> return (t : cs)
+
+ IEModuleContents m
+ | mkModule (modulePackageId mdl) m == mdl -> return localNames
+ | otherwise -> let m' = mkModule (modulePackageId mdl) m in
+ case lookupMod m' of
+ Just mod
+ | OptHide `elem` hmod_options mod ->
+ return (filter (`elem` scope) (hmod_exports mod))
+ | otherwise -> return []
+ Nothing
+ -> tell (exportModuleMissingErr mdl m') >> return []
+
+ _ -> 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
+-- constructors and field names of a tycon, or all the methods of a
+-- class).
+allSubsOfName :: LookupMod -> Name -> [Name]
+allSubsOfName lookupMod name
+ | isExternalName name =
+ case lookupMod (nameModule name) of
+ Just hmod -> Map.findWithDefault [] name (hmod_sub_map hmod)
+ Nothing -> []
+ | otherwise = error $ "Main.allSubsOfName: unexpected unqual'd name"
+
+
+-- Named documentation
+
+findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name))
+findNamedDoc name entities = search entities
+ where search [] = do
+ tell ["Cannot find documentation for: $" ++ name]
+ return Nothing
+ search ((DocEntity (DocCommentNamed name' doc)):rest)
+ | name == name' = return (Just doc)
+ | otherwise = search rest
+ search (_other_decl : rest) = search rest
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:52:57 +0000