aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/GhcUtils.hs12
-rw-r--r--src/Haddock/Interface/Create.hs203
-rw-r--r--src/Haddock/Types.hs8
-rw-r--r--tests/html-tests/tests/Test.hs10
-rw-r--r--tests/html-tests/tests/Test.html.ref34
5 files changed, 137 insertions, 130 deletions
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index 2fb8c8a3..989563b7 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -20,6 +20,7 @@ import Data.Version
import Control.Applicative ( (<$>) )
import Control.Arrow
import Data.Foldable hiding (concatMap)
+import Data.Function
import Data.Traversable
import Distribution.Compat.ReadP
import Distribution.Text
@@ -141,6 +142,11 @@ isInstD (TyClD d) = isFamInstDecl d
isInstD _ = False
+isValD :: HsDecl a -> Bool
+isValD (ValD _) = True
+isValD _ = False
+
+
declATs :: HsDecl a -> [a]
declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
declATs _ = []
@@ -167,6 +173,10 @@ reL :: a -> Located a
reL = L undefined
+before :: Located a -> Located a -> Bool
+before = (<) `on` getLoc
+
+
instance Foldable (GenLocated l) where
foldMap f (L _ x) = f x
@@ -253,7 +263,7 @@ modifySessionDynFlags f = do
-- | A variant of 'gbracket' where the return value from the first computation
-- is not required.
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
-gbracket_ before after thing = gbracket before (const after) (const thing)
+gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
-------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 155cd938..5f633a0b 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -24,6 +24,7 @@ import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Data.Maybe
+import Data.Monoid
import Data.Ord
import Control.Monad
import qualified Data.Traversable as Traversable
@@ -67,8 +68,8 @@ createInterface tm flags modMap instIfaceMap = do
declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ]
instanceDocMap = mkInstanceDocMap localInsts declDocs
- decls = filterOutInstances decls0
- declMap = mkDeclMap decls
+ declMap = mkDeclMap decls0
+ decls = filter (\(L _ d, _, _) -> not (isInstD d || isValD d)) decls0
exports0 = fmap (reverse . map unLoc) optExports
exports
| OptIgnoreExports `elem` opts = Nothing
@@ -171,16 +172,23 @@ mkSubMap declMap exports =
filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ]
--- Make a map from names to 'DeclInfo's. Exclude declarations that don't have
--- names (e.g. instances and stand-alone documentation comments). Include
--- subordinate names, but map them to their parent declarations.
+-- Make a map from names to 'DeclInfo's.
+--
+-- Exclude nameless declarations (e.g. instances and stand-alone documentation
+-- comments). Merge declarations of same names (i.e. type signatures and
+-- bindings). Include subordinate names, mapped to their parent declarations.
mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
-mkDeclMap decls = Map.fromList . concat $
- [ decls_ ++ subDecls
- | (parent@(L _ d), doc, subs) <- decls
+mkDeclMap decls = Map.fromListWith merge . concat $
+ [ decls_ ++ subDecls | (parent@(L _ d), doc, subs) <- decls
, let decls_ = [ (name, (parent, doc, subs)) | name <- getMainDeclBinder d ]
subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
- , not (isDocD d), not (isInstD d) ]
+ , not (isDocD d), not (isInstD d)
+ ]
+ where
+ merge (s@(L _ (SigD _)), s_doc, _) (v@(L _ (ValD _)), v_doc, _) = (s, f s s_doc v v_doc, [])
+ merge (v@(L _ (ValD _)), v_doc, _) (s@(L _ (SigD _)), s_doc, _) = (s, f s s_doc v v_doc, [])
+ merge a _ = a
+ f s s_doc v v_doc | s `before` v = s_doc `mappend` v_doc | otherwise = v_doc `mappend` s_doc
declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
@@ -267,25 +275,25 @@ topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup
-filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)]
-filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d))
-
-
-- | Take all declarations except pragmas, infix decls, rules and value
-- bindings from an 'HsGroup'.
declsFromGroup :: HsGroup Name -> [Decl]
declsFromGroup group_ =
- mkDecls (concat . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls hs_instds InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_
+ mkDecls (concat . hs_tyclds) TyClD group_ ++
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+ mkDecls hs_instds InstD group_ ++
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+ mkDecls (valbinds . hs_valds) ValD group_
where
typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
typesigs _ = error "expected ValBindsOut"
+ valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+ valbinds _ = error "expected ValBindsOut"
+
-- | Take a field of declarations from a data structure and create HsDecls
-- using the given constructor
@@ -335,6 +343,7 @@ filterDecls decls = filter (isHandled . unL . fst) decls
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (SigD d) = isVanillaLSig (reL d)
+ isHandled (ValD _) = True
-- we keep doc declarations to be able to get at named docs
isHandled (DocD _) = True
isHandled _ = False
@@ -482,6 +491,14 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
case findDecl t of
+ -- Top-level binding from this package without type signature
+ Just (L _ (ValD _), doc, _) -> do
+ mayDecl <- ifaceDecl t
+ case mayDecl of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just decl -> return [ ExportDecl decl doc [] [] ]
+
+ -- Top-level declaration from this module
Just (decl, doc, subs) ->
let declNames = getMainDeclBinder (unL decl)
in case () of
@@ -516,114 +533,36 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
_ -> decl
+
+ -- Declaration from another package
Nothing -> do
- -- If we can't find the declaration, it must belong to
- -- another package
- mbTyThing <- liftGhcToErrMsgGhc $ lookupName t
- -- show the name as exported as well as the name's
- -- defining module (because the latter is where we
- -- looked for the .hi/.haddock). It's to help people
- -- debugging after all, so good to show more info.
- let exportInfoString =
- moduleString thisMod ++ "." ++ getOccString t
- ++ ": "
- ++ pretty (nameModule t) ++ "." ++ getOccString t
-
- case mbTyThing of
- Nothing -> do
- liftErrMsg $ tell
- ["Warning: Couldn't find TyThing for exported "
- ++ exportInfoString ++ "; not documenting."]
- -- Is getting to here a bug in Haddock?
- -- Aren't the .hi files always present?
- return [ ExportNoDecl t [] ]
- Just tyThing -> do
- let hsdecl = tyThingToLHsDecl tyThing
- -- This is not the ideal way to implement haddockumentation
- -- for functions/values without explicit type signatures.
- --
- -- However I didn't find an easy way to implement it properly,
- -- and as long as we're using lookupName it is going to find
- -- the types of local inferenced binds. If we don't check for
- -- this at all, then we'll get the "warning: couldn't find
- -- .haddock" which is wrong.
- --
- -- The reason this is not an ideal implementation
- -- (besides that we take a trip to desugared syntax and back
- -- unnecessarily)
- -- is that Haddock won't be able to detect doc-strings being
- -- attached to such a function, such as,
- --
- -- > -- | this is an identity function
- -- > id a = a
- --
- -- . It's more difficult to say what it ought to mean in cases
- -- where multiple exports are bound at once, like
- --
- -- > -- | comment...
- -- > (a, b) = ...
- --
- -- especially since in the export-list they might not even
- -- be next to each other. But a proper implementation would
- -- really need to find the type of *all* exports as well as
- -- addressing all these issues. This implementation works
- -- adequately. Do you see a way to improve the situation?
- -- Please go ahead! I got stuck trying to figure out how to
- -- get the 'PostTcType's that we want for all the bindings
- -- of an HsBind (you get 'LHsBinds' from 'GHC.typecheckedSource'
- -- for example).
- --
- -- But I might be missing something obvious. What's important
- -- /here/ is that we behave reasonably when we run into one of
- -- those exported type-inferenced values.
- isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do
- let mdl = nameModule t
- if modulePackageId mdl == thisPackage dflags then
- isLoaded (moduleName mdl)
- else return False
-
- if isLocalAndTypeInferenced then do
- -- I don't think there can be any subs in this case,
- -- currently? But better not to rely on it.
- let subs = subordinatesWithNoDocs (unLoc hsdecl)
- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
- else
- -- We try to get the subs and docs
- -- from the installed interface of that package.
- case Map.lookup (nameModule t) instIfaceMap of
- -- It's Nothing in the cases where I thought
- -- Haddock has already warned the user: "Warning: The
- -- documentation for the following packages are not
- -- installed. No links will be generated to these packages:
- -- ..."
- -- But I guess it was Cabal creating that warning. Anyway,
- -- this is more serious than links: it's exported decls where
- -- we don't have the docs that they deserve!
-
- -- We could use 'subordinates' to find the Names of the subs
- -- (with no docs). Is that necessary? Yes it is, otherwise
- -- e.g. classes will be shown without their exported subs.
- Nothing -> do
- liftErrMsg $ tell
- ["Warning: Couldn't find .haddock for exported "
- ++ exportInfoString]
- let subs = subordinatesWithNoDocs (unLoc hsdecl)
- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]
- Just iface -> do
- let subs = case Map.lookup t (instSubMap iface) of
- Nothing -> []
- Just x -> x
- return [ mkExportDecl t
- ( hsdecl
- , fromMaybe noDocForDecl $
- Map.lookup t (instDocMap iface)
- , map (\subt ->
- ( subt ,
- fromMaybe noDocForDecl $
- Map.lookup subt (instDocMap iface)
- )
- ) subs
- )]
+ mayDecl <- ifaceDecl t
+ case mayDecl of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just decl -> do
+ -- We try to get the subs and docs
+ -- from the installed .haddock file for that package.
+ case Map.lookup (nameModule t) instIfaceMap of
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find .haddock for export " ++ pretty t]
+ let subs = subordinatesWithNoDocs (unLoc decl)
+ return [ mkExportDecl t (decl, noDocForDecl, subs) ]
+ Just iface -> do
+ let subs = case Map.lookup t (instSubMap iface) of
+ Nothing -> []
+ Just x -> x
+ return [ mkExportDecl t
+ ( decl
+ , fromMaybe noDocForDecl $
+ Map.lookup t (instDocMap iface)
+ , map (\subt ->
+ ( subt ,
+ fromMaybe noDocForDecl $
+ Map.lookup subt (instDocMap iface)
+ )
+ ) subs
+ )]
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
@@ -648,6 +587,16 @@ mkExportItems modMap thisMod gre exportedNames decls declMap
m = nameModule n
+ifaceDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+ifaceDecl t = do
+ mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ case mayTyThing of
+ Nothing -> do
+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t]
+ return Nothing
+ Just x -> return (Just (tyThingToLHsDecl x))
+
+
-- | Return all export items produced by an exported module. That is, we're
-- interested in the exports produced by \"module B\" in such a scenario:
--
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index fbaf89c5..2b78905c 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -25,6 +25,7 @@ import Control.Arrow
import Data.Typeable
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Monoid
import GHC hiding (NoLink)
import OccName
@@ -289,7 +290,12 @@ data Doc id
| DocPic String
| DocAName String
| DocExamples [Example]
- deriving (Eq, Functor)
+ deriving (Functor)
+
+
+instance Monoid (Doc id) where
+ mempty = DocEmpty
+ mappend = DocAppend
unrenameDoc :: Doc DocName -> Doc Name
diff --git a/tests/html-tests/tests/Test.hs b/tests/html-tests/tests/Test.hs
index d7a0a716..d352f029 100644
--- a/tests/html-tests/tests/Test.hs
+++ b/tests/html-tests/tests/Test.hs
@@ -96,7 +96,9 @@ module Test (
$ a non /literal/ line $
-}
- f'
+ f',
+
+ withType, withoutType
) where
import Hidden
@@ -402,6 +404,12 @@ newp = undefined
-- but f' doesn't get link'd 'f\''
f' :: Int
+-- | Comment on a definition without type signature
+withoutType = undefined
+
+-- | Comment on a definition with type signature
+withType :: Int
+withType = 1
-- Add some definitions here so that this file can be compiled with GHC
diff --git a/tests/html-tests/tests/Test.html.ref b/tests/html-tests/tests/Test.html.ref
index e46f96b5..b9afa1e2 100644
--- a/tests/html-tests/tests/Test.html.ref
+++ b/tests/html-tests/tests/Test.html.ref
@@ -665,6 +665,16 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");};
> :: <a href=""
>Int</a
></li
+ ><li class="src short"
+ ><a href=""
+ >withType</a
+ > :: <a href=""
+ >Int</a
+ ></li
+ ><li class="src short"
+ ><a href=""
+ >withoutType</a
+ > :: a</li
></ul
></div
><div id="interface"
@@ -2230,6 +2240,30 @@ test2
</p
></div
></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:withType" class="def"
+ >withType</a
+ > :: <a href=""
+ >Int</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Comment on a definition with type signature
+</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:withoutType" class="def"
+ >withoutType</a
+ > :: a</p
+ ><div class="doc"
+ ><p
+ >Comment on a definition without type signature
+</p
+ ></div
+ ></div
></div
></div
><div id="footer"
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 06:45:22 +0000