aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Backends/Html.hs125
-rw-r--r--src/Haddock/Interface/AttachInstances.hs11
-rw-r--r--src/Haddock/Interface/Create.hs114
-rw-r--r--src/Haddock/Interface/Rename.hs17
-rw-r--r--src/Haddock/Types.hs3
6 files changed, 189 insertions, 83 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index cd5e9161..ccf92d8c 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -80,7 +80,7 @@ typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds)
-- How to print each export
ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl name decl dc _) = doc dc ++ f (unL decl)
+ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl)
where
f (TyClD d@TyData{}) = ppData d
f (TyClD d@ClassDecl{}) = ppClass d
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 5940f8bb..50db3cc3 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -1,4 +1,4 @@
---
+
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
@@ -549,7 +549,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface
exports = numberSectionHeadings (ifaceRnExportItems iface)
- has_doc (ExportDecl _ _ doc _) = isJust doc
+ has_doc (ExportDecl _ doc _) = isJust doc
has_doc (ExportNoDecl _ _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -626,8 +626,8 @@ numberSectionHeadings exports = go 1 exports
processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable
processExport _ _ _ (ExportGroup lev id0 doc)
= ppDocGroup lev (namedAnchor id0 << docToHtml doc)
-processExport summary links docMap (ExportDecl x decl doc insts)
- = doDecl summary links x decl doc insts docMap
+processExport summary links docMap (ExportDecl decl doc insts)
+ = ppDecl summary links decl doc insts docMap
processExport summmary _ _ (ExportNoDecl _ y [])
= declBox (ppDocName y)
processExport summmary _ _ (ExportNoDecl _ y subs)
@@ -655,20 +655,21 @@ declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm ht
declWithDoc False links loc nm (Just doc) html_decl =
topDeclBox links loc nm html_decl </> docBox (docToHtml doc)
-doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName ->
- Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable
-doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
- where
- doDecl (TyClD d) = doTyClD d
- doDecl (SigD (TypeSig (L _ n) (L _ t))) =
- ppFunSig summary links loc mbDoc (docNameOrig n) t
- doDecl (ForD d) = ppFor summary links loc mbDoc d
-
- doTyClD d0@(TyFamily {}) = ppTyFam summary False links loc mbDoc d0
- doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
- doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0
- doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
+ Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable
+ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of
+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d
+ TyClD d@(TyData {})
+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d
+ | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
+ TyClD d@(TySynonym {})
+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d
+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap d
+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc (docNameOrig n) t
+ ForD d -> ppFor summ links loc mbDoc d
+ InstD d -> Html.emptyTable
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
Name -> HsType DocName -> HtmlTable
@@ -786,36 +787,84 @@ ppTyFam summary associated links loc mbDoc decl
| associated, isJust mbDoc = header </> bodyBox << doc
| associated = header
- | null instances, isNothing mbDoc = header
- | otherwise = header </> bodyBox << (doc </> instancesBit)
+ | null instances, isJust mbDoc = header </> bodyBox << doc
+ | null instances = header
+ | isJust mbDoc = header </> bodyBox << (doc </> instancesBit)
+ | otherwise = header </> bodyBox << instancesBit
where
name = docNameOrig . tcdName $ decl
header = topDeclBox links loc name (ppTyFamHeader summary associated decl)
- doc = case mbDoc of
- Just d -> ndocBox (docToHtml d)
- Nothing -> Html.emptyTable
+ doc = ndocBox . docToHtml . fromJust $ mbDoc
instId = collapseId name
- instancesBit
- | null instances = Html.emptyTable
- | otherwise
- = instHdr instId </>
- tda [theclass "body"] <<
- collapsed thediv instId (
- spacedTable1 << (
- aboves (map (declBox . ppInstHead) instances)
+ instancesBit = instHdr instId </>
+ tda [theclass "body"] <<
+ collapsed thediv instId (
+ spacedTable1 << (
+ aboves (map (declBox . ppInstHead) instances)
+ )
)
- )
-- TODO: get the instances
instances = []
--------------------------------------------------------------------------------
+-- Indexed data types
+--------------------------------------------------------------------------------
+
+
+ppDataInst = undefined
+
+
+--------------------------------------------------------------------------------
+-- Indexed newtypes
+--------------------------------------------------------------------------------
+
+
+ppNewTyInst = undefined
+
+
+--------------------------------------------------------------------------------
+-- Indexed types
+--------------------------------------------------------------------------------
+
+
+ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
+ TyClDecl DocName -> HtmlTable
+ppTyInst summary associated links loc mbDoc decl
+
+ | summary = declWithDoc summary links loc name mbDoc
+ (ppTyInstHeader True associated decl)
+
+ | isJust mbDoc = header </> bodyBox << doc
+ | otherwise = header
+
+ where
+ name = docNameOrig . tcdName $ decl
+
+ header = topDeclBox links loc name (ppTyInstHeader summary associated decl)
+
+ doc = case mbDoc of
+ Just d -> ndocBox (docToHtml d)
+ Nothing -> Html.emptyTable
+
+
+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Html
+ppTyInstHeader summary associated decl =
+
+ keyword "type instance" <+>
+
+ ppAppNameTypes (tcdName decl) typeArgs
+ where
+ typeArgs = map unLoc . fromJust . tcdTyPats $ decl
+
+
+--------------------------------------------------------------------------------
-- Associated Types
--------------------------------------------------------------------------------
@@ -942,10 +991,10 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
-ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->
- Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName ->
- HtmlTable
-ppClassDecl summary links instances orig_c loc mbDoc docMap
+ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->
+ Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName ->
+ HtmlTable
+ppClassDecl summary links instances loc mbDoc docMap
decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)
| summary = ppShortClassDecl summary links decl loc docMap
| otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit)
@@ -954,7 +1003,7 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
| null lsigs = topDeclBox links loc nm hdr
| otherwise = topDeclBox links loc nm (hdr <+> keyword "where")
- nm = docNameOrig . unLoc $ lname
+ nm = docNameOrig . unLoc $ tcdLName decl
ctxt = unLoc lctxt
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
@@ -1036,9 +1085,9 @@ ppShortDataDecl summary links loc mbDoc dataDecl
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
-ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key ->
+ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable
-ppDataDecl summary links instances x loc mbDoc dataDecl
+ppDataDecl summary links instances loc mbDoc dataDecl
| summary = declWithDoc summary links loc name mbDoc
(ppShortDataDecl summary links loc mbDoc dataDecl)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index aed832bb..38fef6b4 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -43,11 +43,12 @@ attachInstances modules filterNames = map attach modules
where
newItems = map attachExport (ifaceExportItems mod)
- attachExport (ExportDecl n decl doc _) =
- ExportDecl n decl doc (case Map.lookup n instMap of
- Nothing -> []
- Just instheads -> instheads)
- attachExport otherExport = otherExport
+ attachExport (ExportDecl decl@(L _ (TyClD d)) doc _)
+ | isClassDecl d || isDataDecl d || isFamilyDecl d =
+ ExportDecl decl doc (case Map.lookup (tcdName d) instMap of
+ Nothing -> []
+ Just instheads -> instheads)
+ attachExport export = export
--------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 24def155..7320af21 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -20,6 +20,7 @@ import Data.Maybe
import Data.Char
import Data.Ord
import Control.Monad
+import Control.Arrow
import GHC
import Outputable
@@ -55,16 +56,18 @@ createInterface ghcMod flags modMap = do
subMap = mkSubMap group
decls = topDecls group
declMap = mkDeclMap decls
+ famMap = Map.empty --mkFamMap decls
ignoreExps = Flag_IgnoreAllExports `elem` flags
exportedNames = ghcExportedNames ghcMod
origEnv = Map.fromList [ (nameOccName n, n) | n <- exportedNames ]
+ instances = ghcInstances ghcMod
visibleNames <- mkVisibleNames mod modMap localNames
(ghcNamesInScope ghcMod)
subMap exports opts declMap
- exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod)
- decls declMap subMap opts exports ignoreExps
+ exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod)decls declMap
+ famMap subMap opts exports ignoreExps instances
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
@@ -121,27 +124,51 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
--- Extract declarations
+-- Declarations
--------------------------------------------------------------------------------
+type DeclWithDoc = (LHsDecl Name, Maybe (HsDoc Name))
+
+
+-- | A list of type or data instance declarations with an optional family
+-- declaration.
+type Family = (Maybe DeclWithDoc, [DeclWithDoc])
+
-- | Make a map from names to declarations with documentation. The map excludes
-- all kinds of instance declarations (including type family instances) and
-- documentation declarations.
-- Subordinate names are mapped to the parent declaration, but with the doc
-- for the subordinate declaration.
+mkDeclMap :: [DeclWithDoc] -> Map Name DeclWithDoc
mkDeclMap decls = Map.fromList [ (n, (L loc d, doc)) | (L loc d, doc) <- decls
, (n, doc) <- (declName d, doc) : subordinates d
- , notDocOrInstance d ]
+ , not (isDoc d), not (isInstance d) ]
+
+
+-- | Group type family instances together. Include the family declaration
+-- if found.
+{-mkFamMap :: [DeclWithDoc] -> Map Name Family
+mkFamMap decls =
+ Map.fromList [ (tcdName $ ex $ head $ g, family g) | g <- groups ]
+ where
+ family g = first listToMaybe $ partition (isFamilyDecl . ex) g
+ groups = groupBy (comparing (tcdName . ex)) $
+ filter (isTyClD . unLoc . fst) decls
+ ex ((L _ (TyClD d)), _) = d
+-}
+
+isTyClD (TyClD _) = True
+isTyClD _ = False
+
+
+isDoc (DocD _) = True
+isDoc _ = False
-notDocOrInstance (InstD _) = False
-notDocOrInstance (TyClD (d@TyData {}))
- | Just _ <- tcdTyPats d = False
-notDocOrInstance (TyClD (d@TySynonym {}))
- | Just _ <- tcdTyPats d = False
-notDocOrInstance (DocD _) = False
-notDocOrInstance _ = True
+isInstance (InstD _) = True
+isInstance (TyClD d) = isFamInstDecl d
+isInstance _ = False
subordinates (TyClD d) = classDataSubs d
@@ -184,9 +211,11 @@ declName (SigD sig) = fromJust $ sigNameNoLoc sig
-- All the top-level declarations of a module, ordered by source location,
--- with documentation attached if it exists
-topDecls :: HsGroup Name -> [(LHsDecl Name, Maybe (HsDoc Name))]
-topDecls = collectDocs . sortByLoc . declsFromGroup
+-- with documentation attached if it exists.
+-- TEMP hack to filter out all instances (we don't want them until
+-- rendering is completely implemented).
+topDecls :: HsGroup Name -> [DeclWithDoc]
+topDecls = filter (\(L _ d, _) -> not (isInstance d)) . collectDocs . sortByLoc . declsFromGroup
-- | Pick out the declarations that we want from a group
@@ -195,12 +224,13 @@ declsFromGroup group =
decls hs_tyclds TyClD group ++
decls hs_fords ForD group ++
decls hs_docs DocD group ++
+ decls hs_instds InstD group ++
decls (sigs . hs_valds) SigD group
where
sigs (ValBindsOut _ x) = x
--- | Takes a field of declarations from a data structure and creates HsDecls
+-- | Take a field of declarations from a data structure and create HsDecls
-- using the given constructor
decls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
@@ -210,6 +240,19 @@ sortByLoc = sortBy (comparing getLoc)
--------------------------------------------------------------------------------
+-- Instances
+--------------------------------------------------------------------------------
+
+{-
+matchingInsts :: Name -> [Instances] -> [Instances]
+matchingInsts name instances = filter ((==) name . is_cls) instances
+
+
+instToData :: Instance -> LHsDecl Name
+instToData inst = TyData {
+-}
+
+--------------------------------------------------------------------------------
-- Collect docs
--
-- To be able to attach the right Haddock comment to the right declaration,
@@ -219,11 +262,11 @@ sortByLoc = sortBy (comparing getLoc)
-- | Collect the docs and attach them to the right declaration
-collectDocs :: [LHsDecl Name] -> [(LHsDecl Name, Maybe (HsDoc Name))]
+collectDocs :: [LHsDecl Name] -> [DeclWithDoc]
collectDocs decls = collect Nothing DocEmpty decls
-collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, Maybe (HsDoc Name))]
+collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [DeclWithDoc]
collect d doc_so_far [] =
case d of
Nothing -> []
@@ -245,8 +288,7 @@ collect d doc_so_far (e:es) =
| otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
-finishedDoc :: LHsDecl Name -> HsDoc Name -> [(LHsDecl Name, Maybe (HsDoc Name))] ->
- [(LHsDecl Name, Maybe (HsDoc Name))]
+finishedDoc :: LHsDecl Name -> HsDoc Name -> [DeclWithDoc] -> [DeclWithDoc]
finishedDoc d DocEmpty rest = (d, Nothing) : rest
finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest
where
@@ -257,7 +299,7 @@ finishedDoc _ _ rest = rest
sameDecl d1 d2 = getLoc d1 == getLoc d2
-
+
mkSubMap :: HsGroup Name -> Map Name [Name]
mkSubMap group = Map.fromList [ (name, subs) | L _ tycld <- hs_tyclds group,
let name:subs = map unLoc (tyClDeclNames tycld) ]
@@ -270,29 +312,37 @@ mkExportItems
:: ModuleMap
-> Module -- this module
-> [Name] -- exported names (orig)
- -> [(LHsDecl Name, Maybe (HsDoc Name))]
- -> Map Name (LHsDecl Name, Maybe (HsDoc Name)) -- maps local names to declarations
+ -> [DeclWithDoc]
+ -> Map Name DeclWithDoc -- maps local names to declarations
+ -> Map Name Family
-> Map Name [Name] -- sub-map for this module
-> [DocOption]
-> Maybe [IE Name]
-> Bool -- --ignore-all-exports flag
+ -> [Instance]
-> ErrMsgM [ExportItem Name]
-mkExportItems modMap this_mod exported_names decls declMap sub_map
- opts maybe_exps ignore_all_exports
+mkExportItems modMap this_mod exported_names decls declMap famMap sub_map
+ opts maybe_exps ignore_all_exports instances
| isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
= everything_local_exported
- | Just specs <- maybe_exps = do
- exps <- mapM lookupExport specs
- return (concat exps)
+ | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs
where
+ instances = [ d | d@(L _ decl, _) <- decls, isInstance decl ]
+
everything_local_exported = -- everything exported
return (fullContentsOfThisModule this_mod decls)
packageId = modulePackageId this_mod
- lookupExport (IEVar x) = declWith x
- lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEVar x) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ -- | Just fam <- Map.lookup t famMap = absFam fam
+ -- | otherwise = declWith t
+ -- where
+ -- absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t
+ -- absFam (Nothing, instances) =
+
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t cs) = declWith t
lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m)
@@ -307,7 +357,7 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map
declWith :: Name -> ErrMsgM [ ExportItem Name ]
declWith t
| Just (decl, maybeDoc) <- findDecl t
- = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
+ = return [ ExportDecl (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
| otherwise
= return []
where
@@ -340,7 +390,7 @@ fullContentsOfThisModule :: Module -> [(LHsDecl Name, Maybe (HsDoc Name))] -> [E
fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls)
where
mkExportItem (L _ (DocD (DocGroup lev doc)), _) = Just $ ExportGroup lev "" doc
- mkExportItem (decl, doc) = Just $ ExportDecl (declName (unLoc decl)) decl doc []
+ mkExportItem (decl, doc) = Just $ ExportDecl decl doc []
-- mkExportItem _ = Nothing -- TODO: see if this is really needed
@@ -407,7 +457,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
-- Pruning
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems items = filter hasDoc items
- where hasDoc (ExportDecl _ _ d _) = isJust d
+ where hasDoc (ExportDecl _ d _) = isJust d
hasDoc _ = True
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index f6ffd7ab..d9488ac2 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -292,6 +292,9 @@ renameDecl d = case d of
ForD d -> do
d' <- renameForD d
return (ForD d')
+ InstD d -> do
+ d' <- renameInstD d
+ return (InstD d')
_ -> error "renameDecl"
@@ -318,11 +321,11 @@ renameTyClD d = case d of
return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)
TySynonym lname ltyvars typats ltype -> do
+ lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
ltype' <- renameLType ltype
typats' <- mapM (mapM renameLType) typats
- -- We skip type patterns here as well.
- return (TySynonym (keepL lname) ltyvars' typats' ltype')
+ return (TySynonym lname' ltyvars' typats' ltype')
ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do
lcontext' <- renameLContext lcontext
@@ -379,17 +382,23 @@ renameForD (ForeignExport lname ltype x) = do
return (ForeignExport (keepL lname) ltype' x)
+renameInstD (InstDecl ltype _ _ lATs) = do
+ ltype <- renameLType ltype
+ lATs' <- mapM renameLTyClD lATs
+ return (InstDecl ltype emptyBag [] lATs')
+
+
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
ExportModule mod -> return (ExportModule mod)
ExportGroup lev id doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id doc')
- ExportDecl x decl doc instances -> do
+ ExportDecl decl doc instances -> do
decl' <- renameLDecl decl
doc' <- mapM renameDoc doc
instances' <- mapM renameInstHead instances
- return (ExportDecl x decl' doc' instances')
+ return (ExportDecl decl' doc' instances')
ExportNoDecl x y subs -> do
y' <- lookupRn id y
subs' <- mapM (lookupRn id) subs
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index e91f28cc..49150b64 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -37,9 +37,6 @@ data ExportItem name
= ExportDecl {
- -- | The original name
- expItemName :: Name,
-
-- | A declaration
expItemDecl :: LHsDecl name,
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:53:50 +0000