aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs6
-rw-r--r--src/Haddock/Backends/LaTeX.hs6
-rw-r--r--src/Haddock/Backends/Xhtml.hs6
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs28
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs4
-rw-r--r--src/Haddock/Convert.hs5
-rw-r--r--src/Haddock/GhcUtils.hs11
-rw-r--r--src/Haddock/Interface/Create.hs41
-rw-r--r--src/Haddock/Interface/Rename.hs1
9 files changed, 78 insertions, 30 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 6405861d..628e1cd0 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -110,7 +110,10 @@ operator x = x
-- How to print each export
ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags (ExportDecl decl dc subdocs _ _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
+ppExport dflags ExportDecl { expItemDecl = L _ decl
+ , expItemMbDoc = (dc, _)
+ , expItemSubDocs = subdocs
+ } = ppDocumentation dflags dc ++ f decl
where
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
@@ -139,6 +142,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
+ addContext (MinimalSig sig) = MinimalSig sig
addContext _ = error "expected TypeSig"
f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 44b3fc35..7b72c030 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -177,7 +177,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
exportListItem :: ExportItem DocName -> LaTeX
-exportListItem (ExportDecl decl _doc subdocs _insts _fixities _splice)
+exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
= sep (punctuate comma . map ppDocBinder $ declNames decl) <>
case subdocs of
[] -> empty
@@ -211,8 +211,8 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
- (Documentation Nothing Nothing, argDocs) _ _ _ _)
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))
+ , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 5e728108..9628a33d 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -533,7 +533,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _ _) = isJust mDoc || isJust mWarning
+ has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -578,7 +578,7 @@ miniSynopsis mdl iface unicode qual =
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-> [Html]
-processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities _splice) =
+processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
((divTopDecl <<).(declElem <<)) <$> case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
(FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
@@ -648,7 +648,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
-processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _ _) = Nothing -- Hide empty instances
+processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index cd504d8e..39276441 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -28,7 +28,7 @@ import Haddock.GhcUtils
import Haddock.Types
import Haddock.Doc (combineDocumentation)
-import Data.List ( intersperse )
+import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid ( mempty )
@@ -37,6 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC
import GHC.Exts
import Name
+import BooleanFormula
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
@@ -406,7 +407,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
, tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
subdocs splice unicode qual =
- if null sigs && null ats
+ if not (any isVanillaLSig sigs) && null ats
then (if summary then id else topDeclElem links loc splice [nm]) hdr
else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+++ shortSubDecls
@@ -441,11 +442,11 @@ ppClassDecl summary links instances fixities loc d subdocs
splice unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
| otherwise = classheader +++ docSection qual d
- +++ atBit +++ methodBit +++ instancesBit
+ +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
where
classheader
- | null lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
- | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
+ | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
+ | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
-- Only the fixity relevant to the class header
fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
@@ -472,6 +473,23 @@ ppClassDecl summary links instances fixities loc d subdocs
-- there are different subdocs for different names in a single
-- type signature?
+ minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
+ -- Miminal complete definition = every method
+ And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
+ sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+ -> noHtml
+
+ -- Minimal complete definition = nothing
+ And [] : _ -> subMinimal $ toHtml "Nothing"
+
+ m : _ -> subMinimal $ ppMinimal False m
+ _ -> noHtml
+
+ ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
+ ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs
+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
+ where wrap | p = parens | otherwise = id
+
instancesBit = ppInstances instances nm unicode qual
ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 6784fb30..d3d94424 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -33,6 +33,7 @@ module Haddock.Backends.Xhtml.Layout (
subFields,
subInstances,
subMethods,
+ subMinimal,
topDeclElem, declElem,
) where
@@ -182,6 +183,9 @@ subInstances qual nm = maybe noHtml wrap . instTable
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
+subMinimal :: Html -> Html
+subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
+
-- a box for displaying code
declElem :: Html -> Html
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 1245b2b9..1bf02e3c 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -73,8 +73,9 @@ tyThingToLHsDecl t = noLoc $ case t of
, tcdFDs = map (\ (l,r) -> noLoc
(map getName l, map getName r) ) $
snd $ classTvsFds cl
- , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification)
- (classMethods cl)
+ , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
+ map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+ (classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
, tcdATs = atFamDecls
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index bf6436d1..c06b34a6 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -35,6 +35,7 @@ import GhcMonad (withSession)
import HscTypes
import UniqFM
import GHC
+import Class
moduleString :: Module -> String
@@ -114,6 +115,7 @@ filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
+filterSigNames _ orig@(MinimalSig _) = Just orig
filterSigNames p (TypeSig ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
@@ -279,6 +281,13 @@ modifySessionDynFlags f = do
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
+minimalDef n = do
+ mty <- lookupGlobalName n
+ case mty of
+ Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
+ _ -> return Nothing
-------------------------------------------------------------------------------
-- * DynFlags
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index aef2cd8f..f1262d9f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -437,7 +437,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c }
+ TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -547,17 +547,23 @@ mkExportItems
return []
-- normal case
- | otherwise -> return [ mkExportDecl t newDecl docs_ ]
- where
- -- A single signature might refer to many names, but we
- -- create an export item for a single name only. So we
- -- modify the signature to contain only that single name.
- newDecl = case decl of
- (L loc (SigD sig)) ->
- L loc . SigD . fromJust $ filterSigNames (== t) sig
- -- fromJust is safe since we already checked in guards
- -- that 't' is a name declared in this declaration.
- _ -> decl
+ | otherwise -> case decl of
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
+ L loc (SigD sig) ->
+ -- fromJust is safe since we already checked in guards
+ -- that 't' is a name declared in this declaration.
+ let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
+ in return [ mkExportDecl t newDecl docs_ ]
+
+ L loc (TyClD cl@ClassDecl{}) -> do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef t
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ return [ mkExportDecl t
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+
+ _ -> return [ mkExportDecl t decl docs_ ]
-- Declaration from another package
([], _) -> do
@@ -737,15 +743,20 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| Just name <- M.lookup (getInstLoc d) instMap =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef name
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
mkExportItem decl@(L l d)
- | name:_ <- getMainDeclBinder d =
- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ | name:_ <- getMainDeclBinder d = expDecl decl l name
| otherwise = return Nothing
fixities name subs = [ (n,f) | n <- name : map fst subs
, Just f <- [M.lookup n fixMap] ]
+ expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ where (doc, subs) = lookupDocs name warnings docMap argMap subMap
+
-- | 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
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 4160f4f7..748e0210 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -414,6 +414,7 @@ renameSig sig = case sig of
FixSig (FixitySig lname fixity) -> do
lname' <- renameL lname
return $ FixSig (FixitySig lname' fixity)
+ MinimalSig s -> MinimalSig <$> traverse renameL s
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 08:56:14 +0000