aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs32
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs56
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs4
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs14
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs11
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs183
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs12
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs8
-rw-r--r--haddock-api/src/Haddock/Types.hs50
10 files changed, 261 insertions, 113 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 53cfccff..18660b3f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -227,8 +227,8 @@ isExportModule _ = Nothing
processExport :: ExportItem DocName -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
- = ppDecl decl doc insts subdocs fixities
+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+ = ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
processExport (ExportNoDecl y subs)
@@ -278,16 +278,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
ppDecl :: LHsDecl DocName
+ -> [(HsDecl DocName,DocForDecl DocName)]
-> DocForDecl DocName
-> [DocInstance DocName]
-> [(DocName, DocForDecl DocName)]
-> [(DocName, Fixity)]
-> LaTeX
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc (Just doc) d unicode
+ -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
@@ -565,11 +566,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-------------------------------------------------------------------------------
-ppDataDecl :: [DocInstance DocName] ->
+ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] -> SrcSpan ->
Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
+ppDataDecl pats instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
@@ -579,10 +580,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+ body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
- | null cons = (empty,[])
+ | null cons
+ , null pats = (empty,[])
+ | null cons = (decltt (keyword "where"), repeat empty)
| otherwise = case resTy of
ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
@@ -594,6 +597,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
text "\\end{tabulary}\\par"
+ patternBit
+ | null cons = Nothing
+ | otherwise = Just $
+ text "\\haddockbeginconstrs" $$
+ vcat [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
+ , dcolon unicode
+ , ppLType unicode (hsSigType ty)
+ ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
+ | (SigD (PatSynSig lnames ty),d) <- pats
+ ] $$
+ text "\\end{tabulary}\\par"
+
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 34ecc5b8..249389b9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -604,8 +604,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 035c8e9e..716050fa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,11 +41,12 @@ import BooleanFormula
import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
- -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> [(HsDecl DocName, DocForDecl DocName)]
+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
@@ -613,7 +614,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
, [subFamInstDetails iid pdecl])
where
pdata = keyword "data" <+> typ
- pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
+ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -662,20 +663,23 @@ instanceId origin no orphan ihd = concat $
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName
+ -> [(HsDecl DocName,DocForDecl DocName)]
+ -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl pats unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons
+ , [] <- pats = dataHeader
- | [lcon] <- cons, isH98,
+ | [lcon] <- cons, [] <- pats, isH98,
(cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
- | isH98 = dataHeader
- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+ | [] <- pats, isH98 = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)
| otherwise = (dataHeader <+> keyword "where")
- +++ shortSubDecls dataInst (map doGADTConstr cons)
+ +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)
where
dataHeader
@@ -689,16 +693,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ pats1 = [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppLType unicode qual (hsSigType typ)
+ ]
+ | (SigD (PatSynSig lnames typ),_) <- pats
+ ]
+
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+ [(HsDecl DocName,DocForDecl DocName)] ->
Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode qual
- | summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary False dataDecl pats unicode qual
+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -713,7 +726,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
whereBit
- | null cons = noHtml
+ | null cons
+ , null pats = noHtml
+ | null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
constrBit = subConstructors qual
@@ -723,6 +738,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (getConNames (unLoc c)))) fixities
]
+ patternBit = subPatterns qual
+ [ (hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppLType unicode qual (hsSigType typ)
+ ] <+> ppFixities subfixs qual
+ ,combineDocumentation (fst d), [])
+ | (SigD (PatSynSig lnames typ),d) <- pats
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+ ]
+
instancesBit = ppInstances links (OriginData docname) instances
splice unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 41457f72..6993c7f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subPatterns,
subEquations,
subFields,
subInstances, subOrphanInstances,
@@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
subConstructors :: Qualification -> [SubDecl] -> Html
subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subPatterns :: Qualification -> [SubDecl] -> Html
+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+
subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 4280cd80..02867833 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ import Control.Arrow
import Exception
import Outputable
import Name
+import NameSet
import Lexeme
import Module
import HscTypes
@@ -135,6 +136,17 @@ declATs _ = []
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+ where
+ go !_ [] = []
+ go !s (x:xs)
+ | y `elemNameSet` s = go s xs
+ | otherwise = let !s' = extendNameSet s y
+ in x : go s' xs
+ where
+ y = f x
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5d74819..7a3182b8 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -21,7 +21,6 @@ import Haddock.GhcUtils
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
-import Data.Function (on)
import Data.Maybe ( maybeToList, mapMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -109,13 +108,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
return $ e { expItemInstances = insts }
e -> return e
where
- attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
- nubBy ((==) `on` fst) $ expItemFixities e ++
+ attachFixities e@ExportDecl{ expItemDecl = L _ d
+ , expItemPats = patsyns
+ } = e { expItemFixities =
+ nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
, Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
- , n' <- n : subs
+ , n' <- n : (subs ++ patsyn_names)
, Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
] }
+ where
+ patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
attachFixities e = e
-- spanName: attach the location to the name that is the same file as the instance location
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 36b0b7bb..0984894d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -42,7 +42,7 @@ import Control.Arrow (second)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad
-import Data.Function (on)
+import Data.Traversable
import qualified Packages
import qualified Module
@@ -81,7 +81,10 @@ createInterface tm flags modMap instIfaceMap = do
!fam_instances = md_fam_insts md
!exportedNames = modInfoExports mi
- (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
+ (TcGblEnv { tcg_rdr_env = gre
+ , tcg_warns = warnings
+ , tcg_patsyns = patsyns
+ }, md) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -101,6 +104,28 @@ createInterface tm flags modMap instIfaceMap = do
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
+
+ exports0 = fmap (reverse . map unLoc) mayExports
+ exports
+ | OptIgnoreExports `elem` opts = Nothing
+ | otherwise = exports0
+ warningMap = mkWarningMap dflags warnings gre exportedNames
+
+ localBundledPatSyns :: Map Name [Name]
+ localBundledPatSyns =
+ case exports of
+ Nothing -> M.empty
+ Just ies ->
+ M.map (nubByName id) $
+ M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)
+ | IEThingWith (L _ ty_name) _ exported _ <- ies
+ , let bundled_patsyns =
+ filter is_patsyn (map (ieWrappedName . unLoc) exported)
+ , not (null bundled_patsyns)
+ ]
+ where
+ is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))
+
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom sem_mdl)
@@ -112,18 +137,12 @@ createInterface tm flags modMap instIfaceMap = do
maps@(!docMap, !argMap, !subMap, !declMap, _) =
mkMaps dflags gre localInsts declsWithDocs
- let exports0 = fmap (reverse . map unLoc) mayExports
- exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
- warningMap = mkWarningMap dflags warnings gre exportedNames
-
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-- 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
+ maps localBundledPatSyns fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -147,32 +166,33 @@ createInterface tm flags modMap instIfaceMap = do
tokenizedSrc <- mkMaybeTokenizedSrc flags tm
return $! Interface {
- ifaceMod = mdl
- , ifaceIsSig = is_sig
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = docMap
- , ifaceArgMap = argMap
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = []
- , ifaceExports = exportedNames
- , ifaceVisibleExports = visibleNames
- , ifaceDeclMap = declMap
- , ifaceSubMap = subMap
- , ifaceFixMap = fixMap
- , ifaceModuleAliases = aliases
- , ifaceInstances = instances
- , ifaceFamInstances = fam_instances
+ ifaceMod = mdl
+ , ifaceIsSig = is_sig
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceBundledPatSynMap = localBundledPatSyns
+ , ifaceSubMap = subMap
+ , ifaceFixMap = fixMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceFamInstances = fam_instances
, ifaceOrphanInstances = [] -- Filled in `attachInstances`
, ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
- , ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warningMap
- , ifaceTokenizedSrc = tokenizedSrc
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
+ , ifaceTokenizedSrc = tokenizedSrc
}
-- | Given all of the @import M as N@ declarations in a package,
@@ -295,8 +315,9 @@ mkMaps :: DynFlags
-> [(LHsDecl Name, [HsDocString])]
-> Maps
mkMaps dflags gre instances decls =
- let (a, b, c, d) = unzip4 $ map mappings decls
- in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+ let
+ (a, b, c, d) = unzip4 $ map mappings decls
+ in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap)
where
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
@@ -362,7 +383,9 @@ 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
+ -> HsDecl Name
+ -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
DataFamInstDecl { dfid_tycon = L l _
@@ -539,6 +562,7 @@ mkExportItems
-> [Name] -- exported names (orig)
-> [LHsDecl Name] -- renamed source declarations
-> Maps
+ -> Map Name [Name]
-> FixMap
-> [SrcSpan] -- splice locations
-> Maybe [IE Name]
@@ -547,15 +571,21 @@ mkExportItems
-> ErrMsgGhc [ExportItem Name]
mkExportItems
is_sig modMap thisMod semMod warnings gre exportedNames decls
- maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
+ maps@(docMap, argMap, subMap, declMap, instMap) patSynMap 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 $ ieWrappedName x
- lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t
- lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
+ lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x
+ lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t
+ lookupExport (IEThingAll (L _ t)) = do
+ let name = ieWrappedName t
+ pats <- findBundledPatterns name
+ declWith pats name
+ lookupExport (IEThingWith (L _ t) _ _ _) = do
+ let name = ieWrappedName t
+ pats <- findBundledPatterns name
+ declWith pats name
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
@@ -574,8 +604,8 @@ mkExportItems
Nothing -> []
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
- declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t = do
+ declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
+ declWith pats t = do
r <- findDecl t
case r of
([L l (ValD _)], (doc, _)) -> do
@@ -612,15 +642,15 @@ mkExportItems
-- 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_ ]
+ in return [ mkExportDecl t newDecl pats docs_ ]
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]
- _ -> return [ mkExportDecl t decl docs_ ]
+ _ -> return [ mkExportDecl t decl pats docs_ ]
-- Declaration from another package
([], _) -> do
@@ -637,20 +667,24 @@ mkExportItems
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
- return [ mkExportDecl t decl (noDocForDecl, subs_) ]
+ return [ mkExportDecl t decl pats (noDocForDecl, subs_) ]
Just iface ->
- return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
- mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
- mkExportDecl name decl (doc, subs) = decl'
+ mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)]
+ -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
+ mkExportDecl name decl pats (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False
subs' = filter (isExported . fst) subs
+ pats' = [ d | d@(patsyn_decl, _) <- pats
+ , all isExported (getMainDeclBinder patsyn_decl) ]
sub_names = map fst subs'
- fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
+ pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]
+ fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ]
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
@@ -684,6 +718,40 @@ mkExportItems
where
m = nameModule n
+ findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)]
+ findBundledPatterns t =
+ let
+ m = nameModule t
+
+ local_bundled_patsyns =
+ M.findWithDefault [] t patSynMap
+
+ iface_bundled_patsyns
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)
+ = patsyns
+
+ | Just iface <- M.lookup m instIfaceMap
+ , Just patsyns <- M.lookup t (instBundledPatSynMap iface)
+ = patsyns
+
+ | otherwise
+ = []
+
+ patsyn_decls = do
+ for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do
+ -- call declWith here so we don't have to prepare the pattern synonym for
+ -- showing ourselves.
+ export_items <- declWith [] patsyn_name
+ pure [ (unLoc patsyn_decl, patsyn_doc)
+ | ExportDecl {
+ expItemDecl = patsyn_decl
+ , expItemMbDoc = patsyn_doc
+ } <- export_items
+ ]
+
+ in concat <$> patsyn_decls
+
-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
-- we can actually find in the 'IfaceMap'.
semToIdMod :: UnitId -> Module -> Module
@@ -718,7 +786,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)
+ Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
where
fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
fixities = case fixity of
@@ -873,12 +941,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
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))
+ 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
expInst decl l name =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
-- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -958,8 +1026,9 @@ mkVisibleNames (_, _, _, _, instMap) exports opts
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
where
- exportName e@ExportDecl {} = name ++ subs
- where subs = map fst (expItemSubDocs e)
+ exportName e@ExportDecl {} = name ++ subs ++ patsyns
+ where subs = map fst (expItemSubDocs e)
+ patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
decl -> getMainDeclBinder decl
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b43860fb..5820c61e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -55,7 +55,7 @@ renameInterface dflags renamingEnv warnings iface =
-- combine the missing names and filter out the built-ins, which would
-- otherwise always be missing.
- missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
+ missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much
(missingNames1 ++ missingNames2 ++ missingNames3
++ missingNames4 ++ missingNames5)
@@ -314,6 +314,11 @@ renameInstHead InstHead {..} = do
renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
+renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)]
+renamePats = mapM
+ (\(d,doc) -> do { d' <- renameDecl d
+ ; doc' <- renameDocForDecl doc
+ ; return (d',doc')})
renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
renameDecl decl = case decl of
@@ -601,15 +606,16 @@ renameExportItem item = case item of
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
- ExportDecl decl doc subs instances fixities splice -> do
+ ExportDecl decl pats doc subs instances fixities splice -> do
decl' <- renameLDecl decl
+ pats' <- renamePats pats
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
instances' <- forM instances renameDocInstance
fixities' <- forM fixities $ \(name, fixity) -> do
name' <- lookupRn name
return (name', fixity)
- return (ExportDecl decl' doc' subs' instances' fixities' splice)
+ return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index e5c2face..054c1384 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)
-binaryInterfaceVersion = 30
+binaryInterfaceVersion = 31
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -373,7 +373,7 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
put_ bh (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap fixMap) = do
+ exps visExps opts subMap patSynMap fixMap) = do
put_ bh modu
put_ bh is_sig
put_ bh info
@@ -382,6 +382,7 @@ instance Binary InstalledInterface where
put_ bh visExps
put_ bh opts
put_ bh subMap
+ put_ bh patSynMap
put_ bh fixMap
get bh = do
@@ -393,10 +394,11 @@ instance Binary InstalledInterface where
visExps <- get bh
opts <- get bh
subMap <- get bh
+ patSynMap <- get bh
fixMap <- get bh
return (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap fixMap)
+ exps visExps opts subMap patSynMap fixMap)
instance Binary DocOption where
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 803995cc..bfc8e32b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -103,6 +103,9 @@ data Interface = Interface
-- names of subordinate declarations mapped to their parent declarations.
, ifaceDeclMap :: !(Map Name [LHsDecl Name])
+ -- | Bundled pattern synonym declarations for specific types.
+ , ifaceBundledPatSynMap :: !(Map Name [Name])
+
-- | Documentation of declarations originating from the module (including
-- subordinates).
, ifaceDocMap :: !(DocMap Name)
@@ -158,49 +161,53 @@ type WarningMap = Map Name (Doc Name)
data InstalledInterface = InstalledInterface
{
-- | The module represented by this interface.
- instMod :: Module
+ instMod :: Module
-- | Is this a signature?
- , instIsSig :: Bool
+ , instIsSig :: Bool
-- | Textual information about the module.
- , instInfo :: HaddockModInfo Name
+ , instInfo :: HaddockModInfo Name
-- | Documentation of declarations originating from the module (including
-- subordinates).
- , instDocMap :: DocMap Name
+ , instDocMap :: DocMap Name
- , instArgMap :: ArgMap Name
+ , instArgMap :: ArgMap Name
-- | All names exported by this module.
- , instExports :: [Name]
+ , instExports :: [Name]
-- | All \"visible\" names exported by the module.
-- A visible name is a name that will show up in the documentation of the
-- module.
- , instVisibleExports :: [Name]
+ , instVisibleExports :: [Name]
-- | Haddock options for this module (prune, ignore-exports, etc).
- , instOptions :: [DocOption]
+ , instOptions :: [DocOption]
+
+ , instSubMap :: Map Name [Name]
- , instSubMap :: Map Name [Name]
- , instFixMap :: Map Name Fixity
+ , instBundledPatSynMap :: Map Name [Name]
+
+ , instFixMap :: Map Name Fixity
}
-- | Convert an 'Interface' to an 'InstalledInterface'
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
- { instMod = ifaceMod interface
- , instIsSig = ifaceIsSig interface
- , instInfo = ifaceInfo interface
- , instDocMap = ifaceDocMap interface
- , instArgMap = ifaceArgMap interface
- , instExports = ifaceExports interface
- , instVisibleExports = ifaceVisibleExports interface
- , instOptions = ifaceOptions interface
- , instSubMap = ifaceSubMap interface
- , instFixMap = ifaceFixMap interface
+ { instMod = ifaceMod interface
+ , instIsSig = ifaceIsSig interface
+ , instInfo = ifaceInfo interface
+ , instDocMap = ifaceDocMap interface
+ , instArgMap = ifaceArgMap interface
+ , instExports = ifaceExports interface
+ , instVisibleExports = ifaceVisibleExports interface
+ , instOptions = ifaceOptions interface
+ , instSubMap = ifaceSubMap interface
+ , instBundledPatSynMap = ifaceBundledPatSynMap interface
+ , instFixMap = ifaceFixMap interface
}
@@ -217,6 +224,9 @@ data ExportItem name
-- | A declaration.
expItemDecl :: !(LHsDecl name)
+ -- | Bundled patterns for a data type declaration
+ , expItemPats :: ![(HsDecl name, DocForDecl name)]
+
-- | Maybe a doc comment, and possibly docs for arguments (if this
-- decl is a function or type-synonym).
, expItemMbDoc :: !(DocForDecl name)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:14:36 +0000