aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs16
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs86
-rw-r--r--haddock-api/src/Haddock/Convert.hs16
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs175
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs3
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs10
-rw-r--r--haddock-api/src/Haddock/Types.hs11
-rw-r--r--haddock-api/src/Haddock/Utils.hs12
11 files changed, 210 insertions, 132 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 547e22c2..6af0874a 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -68,7 +68,6 @@ import System.Directory (doesDirectoryExist)
import GHC hiding (verbosity)
import Config
import DynFlags hiding (projectVersion, verbosity)
-import StaticFlags (discardStaticFlags)
import Packages
import Panic (handleGhcException)
import Module
@@ -336,7 +335,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
libDir
- when (Flag_HyperlinkedSource `elem` flags) $ do
+ when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
-- | From GHC 7.10, this function has a potential to crash with a
@@ -410,18 +409,9 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
parseGhcFlags dynflags = do
-- TODO: handle warnings?
- -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
- -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
- -- we pass any, Haddock will fail. Since StaticFlags are global to the
- -- GHC invocation, there's also no way to reparse/save them to set them
- -- again properly.
- --
- -- This is a bit of a hack until we get rid of the rest of the remaining
- -- StaticFlags. See GHC issue #8276.
- let flags' = discardStaticFlags flags
- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags)
if not (null rest)
- then throwE ("Couldn't parse GHC options: " ++ unwords flags')
+ then throwE ("Couldn't parse GHC options: " ++ unwords flags)
else return dynflags'
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index aff61cfc..b97f0ead 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -152,11 +152,11 @@ imports src@(_, imps, _, _) =
everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just (GHC.IEVar v)) -> pure $ var v
- (Just (GHC.IEThingAbs t)) -> pure $ typ t
- (Just (GHC.IEThingAll t)) -> pure $ typ t
+ (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith t _ vs _fls)) ->
- [typ t] ++ map var vs
+ [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 9fd55e49..7b5f9017 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -35,8 +35,8 @@ import Text.XHtml hiding ( name, title, p, quote )
import Haddock.GhcUtils
import Control.Monad ( when, unless )
-import Data.Char ( toUpper )
-import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )
+import Data.Char ( toUpper, isSpace )
+import Data.List ( sortBy, intercalate, isPrefixOf, intersperse )
import Data.Maybe
import System.FilePath hiding ( (</>) )
import System.Directory
@@ -105,7 +105,8 @@ copyHtmlBits odir libdir themes = do
copyCssFile f = copyFile f (combine odir (takeFileName f))
copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
mapM_ copyCssFile (cssFiles themes)
- mapM_ copyLibFile [ jsFile, framesFile ]
+ copyLibFile jsFile
+ return ()
headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html
@@ -201,8 +202,7 @@ moduleInfo iface =
field info >>= \a -> return (th << fieldName <-> td << a)
entries :: [HtmlTable]
- entries = mapMaybe doOneEntry [
- ("Copyright",hmi_copyright),
+ entries = maybeToList copyrightsTable ++ mapMaybe doOneEntry [
("License",hmi_license),
("Maintainer",hmi_maintainer),
("Stability",hmi_stability),
@@ -216,6 +216,14 @@ moduleInfo iface =
Just Haskell98 -> Just "Haskell98"
Just Haskell2010 -> Just "Haskell2010"
+ multilineRow :: String -> [String] -> HtmlTable
+ multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
+ where toLines = mconcat . intersperse br . map toHtml
+
+ copyrightsTable :: Maybe HtmlTable
+ copyrightsTable = fmap (multilineRow "Copyright" . split) (hmi_copyright info)
+ where split = map (trim . filter (/= ',')) . lines
+
extsForm
| OptShowExtensions `elem` ifaceOptions iface =
let fs = map (dropOpt . show) (hmi_extensions info)
@@ -256,21 +264,25 @@ ppHtmlContents dflags odir doctitle _maybe_package
themes mathjax_url maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
let tree = mkModuleTree dflags showPkgs
- [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , not (instIsSig iface)]
+ sig_tree = mkModuleTree dflags showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , instIsSig iface]
html =
headHtml doctitle Nothing themes mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
ppPrologue qual doctitle prologue,
+ ppSignatureTree qual sig_tree,
ppModuleTree qual tree
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
- -- XXX: think of a better place for this?
- ppHtmlContentsFrame odir doctitle themes mathjax_url ifaces debug
-
ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
ppPrologue _ _ Nothing = noHtml
@@ -278,7 +290,13 @@ ppPrologue qual title (Just doc) =
divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+ppSignatureTree :: Qualification -> [ModuleTree] -> Html
+ppSignatureTree qual ts =
+ divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+
+
ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree _ [] = mempty
ppModuleTree qual ts =
divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
@@ -321,39 +339,6 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
--- | Turn a module tree into a flat list of full module names. E.g.,
--- @
--- A
--- +-B
--- +-C
--- @
--- becomes
--- @["A", "A.B", "A.B.C"]@
-flatModuleTree :: [InstalledInterface] -> [Html]
-flatModuleTree ifaces =
- map (uncurry ppModule' . head)
- . groupBy ((==) `on` fst)
- . sortBy (comparing fst)
- $ mods
- where
- mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
- ppModule' txt mdl =
- anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
- << toHtml txt
-
-
-ppHtmlContentsFrame :: FilePath -> String -> Themes -> Maybe String
- -> [InstalledInterface] -> Bool -> IO ()
-ppHtmlContentsFrame odir doctitle themes maybe_mathjax_url ifaces debug = do
- let mods = flatModuleTree ifaces
- html =
- headHtml doctitle Nothing themes maybe_mathjax_url +++
- miniBody << divModuleList <<
- (sectionName << "Modules" +++
- ulist << [ li ! [theclass "module"] << m | m <- mods ])
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
-
--------------------------------------------------------------------------------
-- * Generate the index
@@ -498,13 +483,20 @@ ppHtmlModule odir doctitle themes
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
+ mdl_str_annot = mdl_str ++ if ifaceIsSig iface
+ then " (signature)"
+ else ""
+ mdl_str_linked = mdl_str +++
+ " (signature" +++
+ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
+ ")"
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+ headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
- divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
]
@@ -512,6 +504,9 @@ ppHtmlModule odir doctitle themes
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
+signatureDocURL :: String
+signatureDocURL = "https://wiki.haskell.org/Module_signature"
+
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
@@ -684,6 +679,9 @@ processDecl :: Bool -> Html -> Maybe Html
processDecl True = Just
processDecl False = Just . divTopDecl
+trim :: String -> String
+trim = f . f
+ where f = reverse . dropWhile isSpace
processDeclOneLiner :: Bool -> Html -> Maybe Html
processDeclOneLiner True = Just
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 87a273b2..01261477 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,3 +1,4 @@
+
{-# LANGUAGE CPP, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
@@ -34,10 +35,10 @@ import TcType ( tcSplitSigmaTy )
import TyCon
import Type
import TyCoRep
-import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )
+import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
import PrelNames ( hasKey, eqTyConKey, ipClassKey
- , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )
+ , tYPETyConKey, liftedRepDataConKey )
import Unique ( getUnique )
import Util ( filterByList, filterOut )
import Var
@@ -114,7 +115,8 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
hs_rhs = synifyType WithinType rhs
in TyFamEqn { tfe_tycon = name
, tfe_pats = HsIB { hsib_body = typats
- , hsib_vars = map tyVarName tkvs }
+ , hsib_vars = map tyVarName tkvs
+ , hsib_closed = True }
, tfe_fixity = Prefix
, tfe_rhs = hs_rhs }
@@ -300,7 +302,7 @@ synifyDataCon use_gadt_syntax dc =
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
- gadt_ty = HsIB [] (synifyType WithinType res_ty)
+ gadt_ty = HsIB [] (synifyType WithinType res_ty) False
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
\hat ->
@@ -378,12 +380,8 @@ synifyType _ (TyConApp tc tys)
-- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
- , lev `hasKey` ptrRepLiftedDataConKey
+ , lev `hasKey` liftedRepDataConKey
= noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
- | tc `hasKey` tYPETyConKey
- , [TyConApp lev []] <- tys
- , lev `hasKey` ptrRepUnliftedDataConKey
- = noLoc (HsTyVar NotPromoted (noLoc unliftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4e1a9b3a..e594feae 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -11,6 +11,10 @@
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
+--
+-- This module provides a single function 'createInterface',
+-- which creates a Haddock 'Interface' from the typechecking
+-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where
@@ -36,7 +40,6 @@ import Control.Arrow (second)
import Control.DeepSeq
import Control.Monad
import Data.Function (on)
-import qualified Data.Foldable as F
import qualified Packages
import qualified Module
@@ -50,12 +53,16 @@ import TcRnTypes
import FastString (concatFS)
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
-import HsDecls ( gadtDeclDetails,getConDetails )
+import HsDecls ( getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface :: TypecheckedModule
+ -> [Flag] -- Boolean flags
+ -> IfaceMap -- Locally processed modules
+ -> InstIfaceMap -- External, already installed interfaces
+ -> ErrMsgGhc Interface
createInterface tm flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
@@ -63,6 +70,8 @@ createInterface tm flags modMap instIfaceMap = do
L _ hsm = parsedSource tm
!safety = modInfoSafe mi
mdl = ms_mod ms
+ sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
+ is_sig = ms_hsc_src ms == HsigFile
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
@@ -84,13 +93,15 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
+ -- Process the top-level module header documentation.
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
- ++ map getName fam_instances
+ localInsts = filter (nameIsLocalOrFrom sem_mdl)
+ $ map getName instances
+ ++ map getName fam_instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
@@ -105,7 +116,9 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ -- The MAIN functionality: compute the export items which will
+ -- each be the actual documentation of this module.
+ exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
maps fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -131,6 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
return $! Interface {
ifaceMod = mdl
+ , ifaceIsSig = is_sig
, ifaceOrigFilename = msHsFilePath ms
, ifaceInfo = info
, ifaceDoc = Documentation mbDoc modWarn
@@ -157,6 +171,10 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+-- | Given all of the @import M as N@ declarations in a package,
+-- create a mapping from the module identity of M, to an alias N
+-- (if there are multiple aliases, we pick the last one.) This
+-- will go in 'ifaceModuleAliases'.
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
case mRenamedSource of
@@ -167,13 +185,28 @@ mkAliasMap dflags mRenamedSource =
SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
(fmap Module.fsToUnitId $
fmap sl_fs $ ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
--- similar to GHC.lookupModule
+-- Similar to GHC.lookupModule
+-- ezyang: Not really...
lookupModuleDyn ::
DynFlags -> Maybe UnitId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
@@ -323,6 +356,8 @@ mkMaps dflags gre instances decls =
-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
@@ -491,12 +526,14 @@ collectDocs = go Nothing []
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: IfaceMap
+ :: Bool -- is it a signature
+ -> IfaceMap
-> Module -- this module
+ -> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name]
+ -> [LHsDecl Name] -- renamed source declarations
-> Maps
-> FixMap
-> [SrcSpan] -- splice locations
@@ -505,17 +542,22 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod warnings gre exportedNames decls
+ is_sig modMap thisMod semMod warnings gre exportedNames decls
maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar (L _ x)) = declWith x
- lookupExport (IEThingAbs (L _ t)) = declWith t
- lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
+ lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x
+ lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t
+ lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
lookupExport (IEModuleContents (L _ m)) =
+ -- TODO: We could get more accurate reporting here if IEModuleContents
+ -- also recorded the actual names that are exported here. We CAN
+ -- compute this info using @gre@ but 'moduleExports does not seem to
+ -- do so.
+ -- NB: Pass in identity module, so we can look it up in index correctly
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = return $
return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -529,8 +571,9 @@ mkExportItems
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t =
- case findDecl t of
+ declWith t = do
+ r <- findDecl t
+ case r of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -583,6 +626,8 @@ mkExportItems
Just decl ->
-- We try to get the subs and docs
-- from the installed .haddock file for that package.
+ -- TODO: This needs to be more sophisticated to deal
+ -- with signature inheritance
case M.lookup (nameModule t) instIfaceMap of
Nothing -> do
liftErrMsg $ tell
@@ -598,8 +643,7 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
- mdl = nameModule name
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
@@ -608,16 +652,41 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
- | m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n warnings docMap argMap subMap)
- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
- | otherwise = ([], (noDocForDecl, []))
+ | m == semMod =
+ case M.lookup n declMap of
+ Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+ Nothing
+ | is_sig -> do
+ -- OK, so it wasn't in the local declaration map. It could
+ -- have been inherited from a signature. Reconstitute it
+ -- from the type.
+ mb_r <- hiDecl dflags n
+ case mb_r of
+ Nothing -> return ([], (noDocForDecl, []))
+ -- TODO: If we try harder, we might be able to find
+ -- a Haddock! Look in the Haddocks for each thing in
+ -- requirementContext (pkgState)
+ Just decl -> return ([decl], (noDocForDecl, []))
+ | otherwise ->
+ return ([], (noDocForDecl, []))
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just ds <- M.lookup n (ifaceDeclMap iface) =
+ return (ds, lookupDocs n warnings
+ (ifaceDocMap iface)
+ (ifaceArgMap iface)
+ (ifaceSubMap iface))
+ | otherwise = return ([], (noDocForDecl, []))
where
m = nameModule n
+-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
+-- we can actually find in the 'IfaceMap'.
+semToIdMod :: UnitId -> Module -> Module
+semToIdMod this_uid m
+ | Module.isHoleModule m = mkModule this_uid (moduleName m)
+ | otherwise = m
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
hiDecl dflags t = do
@@ -680,13 +749,13 @@ lookupDocs n warnings docMap argMap subMap =
-- only return those that are.
-- 3) B is visible and all its exports are in scope, in which case we return
-- a single 'ExportModule' item.
-moduleExports :: Module -- ^ Module A
+moduleExports :: Module -- ^ Module A (identity, NOT semantic)
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
-> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the declarations in A
+ -> [LHsDecl Name] -- ^ All the renamed declarations in A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
@@ -694,8 +763,11 @@ moduleExports :: Module -- ^ Module A
-> [SrcSpan] -- ^ Locations of all TH splices
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | expMod == moduleName thisMod
+ = fullModuleContents dflags warnings gre maps fixMap splices decls
| otherwise =
+ -- NB: we constructed the identity module when looking up in
+ -- the IfaceMap.
case M.lookup m ifaceMap of
Just iface
| OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
@@ -711,7 +783,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule unitId expMod
+ m = mkModule unitId expMod -- Identity module!
unitId = moduleUnitId thisMod
@@ -732,8 +804,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+-- | Simplified variant of 'mkExportItems', where we can assume that
+-- every locally defined declaration is exported; thus, we just
+-- zip through the renamed declarations.
+fullModuleContents :: DynFlags
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
+ -> [LHsDecl Name] -- ^ All the renamed declarations
+ -> ErrMsgGhc [ExportItem Name]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
@@ -790,26 +871,34 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
-- 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
+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
TyClD d@ClassDecl {} ->
- let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isTypeLSig sig ] -- TODO: document fixity
+ let matches = [ lsig
+ | lsig <- tcdSigs d
+ , ClassOpSig False _ _ <- pure $ unLoc lsig
+ -- Note: exclude `default` declarations (see #505)
+ , name `elem` sigName lsig
+ ]
+ -- TODO: document fixity
in case matches of
[s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
- _ -> error "internal: extractDecl (ClassDecl)"
+ _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
+ O.$$ O.nest 4 (O.ppr d)
+ O.$$ O.text "Matches:"
+ O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
+ in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
, dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
- SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+ SigD <$> extractRecSel name n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d | L _ d <- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
@@ -819,25 +908,25 @@ extractDecl name mdl decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
-extractRecSel nm mdl t tvs (L _ con : rest) =
+extractRecSel nm t tvs (L _ con : rest) =
case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
- _ -> extractRecSel nm mdl t tvs rest
+ _ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
, L l n <- ns, selectorFieldOcc n == nm ]
data_ty
- -- | ResTyGADT _ ty <- con_res con = ty
+ -- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..608344ad 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -31,6 +31,7 @@ import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
+import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
@@ -67,7 +68,7 @@ processModuleHeader dflags gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index e7d2a085..768a31ce 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -76,7 +76,7 @@ parseKey :: String -> String -> Maybe (String,String)
parseKey key toParse0 =
do
let
- (spaces0,toParse1) = extractLeadingSpaces toParse0
+ (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0)
indentation = spaces0
afterKey0 <- extractPrefix key toParse1
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f88d9f4e..b43860fb 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -577,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_vars = PlaceHolder }) }
+ , hsib_vars = PlaceHolder
+ , hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs Name in_thing
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 63419102..796a7ce6 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 801) && (__GLASGOW_HASKELL__ < 803)
-binaryInterfaceVersion = 28
+#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
+binaryInterfaceVersion = 29
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -372,9 +372,10 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu info docMap argMap
+ put_ bh (InstalledInterface modu is_sig info docMap argMap
exps visExps opts subMap fixMap) = do
put_ bh modu
+ put_ bh is_sig
put_ bh info
put_ bh docMap
put_ bh argMap
@@ -386,6 +387,7 @@ instance Binary InstalledInterface where
get bh = do
modu <- get bh
+ is_sig <- get bh
info <- get bh
docMap <- get bh
argMap <- get bh
@@ -395,7 +397,7 @@ instance Binary InstalledInterface where
subMap <- get bh
fixMap <- get bh
- return (InstalledInterface modu info docMap argMap
+ return (InstalledInterface modu is_sig info docMap argMap
exps visExps opts subMap fixMap)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 1f446224..e2bbe6f8 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -78,6 +78,9 @@ data Interface = Interface
-- | The module behind this interface.
ifaceMod :: !Module
+ -- | Is this a signature?
+ , ifaceIsSig :: !Bool
+
-- | Original file name of the module.
, ifaceOrigFilename :: !FilePath
@@ -155,6 +158,9 @@ data InstalledInterface = InstalledInterface
-- | The module represented by this interface.
instMod :: Module
+ -- | Is this a signature?
+ , instIsSig :: Bool
+
-- | Textual information about the module.
, instInfo :: HaddockModInfo Name
@@ -184,6 +190,7 @@ data InstalledInterface = InstalledInterface
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
{ instMod = ifaceMod interface
+ , instIsSig = ifaceIsSig interface
, instInfo = ifaceInfo interface
, instDocMap = ifaceDocMap interface
, instArgMap = ifaceArgMap interface
@@ -451,8 +458,8 @@ instance (NFData a, NFData mod)
DocExamples a -> a `deepseq` ()
DocHeader a -> a `deepseq` ()
-#if __GLASGOW_HASKELL__ < 801
--- These were added to GHC itself in 8.2.1
+#if !MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)
+-- These were added to GHC itself in 8.0.2
instance NFData Name where rnf x = seq x ()
instance NFData OccName where rnf x = seq x ()
instance NFData ModuleName where rnf x = seq x ()
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index ba382600..404cfcf6 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -21,10 +21,9 @@ module Haddock.Utils (
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
contentsHtmlFile, indexHtmlFile,
- frameIndexHtmlFile,
moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
- jsFile, framesFile,
+ jsFile,
-- * Anchor and URL utilities
moduleNameUrl, moduleNameUrl', moduleUrl,
@@ -262,12 +261,6 @@ contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
--- | The name of the module index file to be displayed inside a frame.
--- Modules are display in full, but without indentation. Clicking opens in
--- the main window.
-frameIndexHtmlFile :: String
-frameIndexHtmlFile = "index-frames.html"
-
moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
moduleIndexFrameName = "modules"
@@ -333,9 +326,8 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
-------------------------------------------------------------------------------
-jsFile, framesFile :: String
+jsFile :: String
jsFile = "haddock-util.js"
-framesFile = "frames.html"
-------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 13:26:39 +0000