aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/LaTeX.hs16
-rw-r--r--src/Haddock/Backends/Xhtml.hs1
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs42
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs5
-rw-r--r--src/Haddock/Convert.hs34
-rw-r--r--src/Haddock/GhcUtils.hs11
-rw-r--r--src/Haddock/Interface/AttachInstances.hs57
-rw-r--r--src/Haddock/Interface/Create.hs122
-rw-r--r--src/Haddock/Interface/Rename.hs9
-rw-r--r--src/Haddock/Types.hs22
10 files changed, 181 insertions, 138 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 94adc558..2185340b 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -284,7 +284,7 @@ ppDecl :: LHsDecl DocName
ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc doc d unicode
+ -> ppDataDecl 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 {})
@@ -560,9 +560,11 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode
-ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
-
+ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode
+ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs
+ppInstHead _unicode (_n, _ts, DataInst _dd) =
+ error "data instances not supported by --latex yet"
lookupAnySubdoc :: (Eq name1) =>
name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
@@ -577,8 +579,8 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
ppDataDecl :: [DocInstance DocName] ->
- [(DocName, DocForDecl DocName)] ->
- SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
+ [(DocName, DocForDecl DocName)] -> SrcSpan ->
+ Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
LaTeX
ppDataDecl instances subdocs _loc doc dataDecl unicode
@@ -590,7 +592,7 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
- body = catMaybes [constrBit, documentationToLaTeX doc]
+ body = catMaybes [constrBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
| null cons = (empty,[])
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 3168c7b0..53b106a2 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -648,6 +648,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
+processExport _ _ _ _ (ExportDecl (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)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index acde5a0f..9180c3c3 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links instances loc mbDoc d unicode qual
TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
@@ -212,9 +212,9 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
Nothing -> noHtml
)
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Documentation DocName ->
FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc doc decl unicode qual
+ppTyFam summary associated links instances loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -225,16 +225,19 @@ ppTyFam summary associated links loc doc decl unicode qual
header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
instancesBit
- | FamilyDecl { fdInfo = ClosedTypeFamily _eqns } <- decl
+ | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
, not summary
- = noHtml -- TODO: print eqns
+ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
| otherwise
= ppInstances instances docname unicode qual
- -- TODO: get the instances
- instances = []
-
+ -- Individual equation of a closed type family
+ ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+ , tfie_pats = HsWB { hswb_cts = ts }}
+ = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+ <+> equals <+> ppType unicode qual (unLoc rhs)
+ , Nothing, [] )
--------------------------------------------------------------------------------
-- * Associated Types
@@ -244,7 +247,7 @@ ppTyFam summary associated links loc doc decl unicode qual
ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
-> Qualification -> Html
ppAssocType summ links doc (L loc decl) unicode qual =
- ppTyFam summ True links loc (fst doc) decl unicode qual
+ ppTyFam summ True links [] loc (fst doc) decl unicode qual
--------------------------------------------------------------------------------
@@ -423,10 +426,14 @@ ppInstances instances baseName unicode qual
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> SubDecl
instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead ([], n, ts) = ppAppNameTypes n ts unicode qual
- instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual
+ instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
<+> ppAppNameTypes n ts unicode qual
-
+ instHead (n, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ts unicode qual
+ <+> equals <+> ppType unicode qual rhs
+ instHead (n, ts, DataInst dd) = keyword "data"
+ <+> ppAppNameTypes n ts unicode qual
+ <+> ppShortDataDecl False True dd unicode qual
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
@@ -438,9 +445,8 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-- TODO: print contexts
-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
- -> Qualification -> Html
-ppShortDataDecl summary _links _loc dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl unicode qual
| [] <- cons = dataHeader
@@ -455,7 +461,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
+++ shortSubDecls (map doGADTConstr cons)
where
- dataHeader = ppDataHeader summary dataDecl unicode qual
+ dataHeader
+ | dataInst = noHtml
+ | otherwise = ppDataHeader summary dataDecl unicode qual
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
@@ -469,7 +477,7 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
Qualification -> Html
ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
- | summary = ppShortDataDecl summary links loc dataDecl unicode qual
+ | summary = ppShortDataDecl summary False dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 4584fd82..dbc043be 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subEquations,
subFields,
subInstances,
subMethods,
@@ -165,6 +166,10 @@ subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
subInstances :: Qualification -> String -> [SubDecl] -> Html
subInstances qual nm = maybe noHtml wrap . instTable
where
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 66497783..d9bb0fcf 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -30,6 +30,7 @@ import CoAxiom
import ConLike
import DataCon
import PatSyn
+import FamInstEnv
import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
@@ -38,6 +39,7 @@ import Bag ( emptyBag )
import Unique ( getUnique )
import SrcLoc ( Located, noLoc, unLoc )
import Data.List( partition )
+import Haddock.Types
-- the main function here! yay!
@@ -62,7 +64,7 @@ tyThingToLHsDecl t = noLoc $ case t of
extractFamilyDecl _ =
error "tyThingToLHsDecl: impossible associated tycon"
- atTyClDecls = [synifyTyCon at_tc | (at_tc, _) <- classATItems cl]
+ atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
atFamDecls = map extractFamilyDecl atTyClDecls in
TyClD $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
@@ -80,7 +82,7 @@ tyThingToLHsDecl t = noLoc $ case t of
, tcdDocs = [] --we don't have any docs at this point
, tcdFVs = placeHolderNames }
| otherwise
- -> TyClD (synifyTyCon tc)
+ -> TyClD (synifyTyCon Nothing tc)
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
@@ -119,13 +121,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| Just ax' <- isClosedSynFamilyTyCon_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
- = TyClD (synifyTyCon tc)
+ = TyClD (synifyTyCon (Just ax) tc)
| otherwise
= error "synifyAxiom: closed/open family confusion"
-synifyTyCon :: TyCon -> TyClDecl Name
-synifyTyCon tc
+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
+synifyTyCon coax tc
| isFunTyCon tc || isPrimTyCon tc
= DataDecl { tcdLName = synifyName tc
, tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
@@ -181,7 +183,10 @@ synifyTyCon tc
let
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
- name = synifyName tc
+ name = case coax of
+ Just a -> synifyName a -- Data families are named according to their
+ -- CoAxioms, not their TyCons
+ _ -> synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
kindSig = Just (tyConKind tc)
-- The data constructors.
@@ -365,10 +370,19 @@ synifyTyLit (StrTyLit s) = HsStrTy s
synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
- ([HsType Name], Name, [HsType Name])
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
synifyInstHead (_, preds, cls, ts) =
- ( map (unLoc . synifyType WithinType) preds
- , getName cls
+ ( getName cls
, map (unLoc . synifyType WithinType) ts
+ , ClassInst $ map (unLoc . synifyType WithinType) preds
+ )
+
+-- Convert a family instance, this could be a type family or data family
+synifyFamInst :: FamInst -> InstHead Name
+synifyFamInst fi =
+ ( fi_fam fi
+ , map (unLoc . synifyType WithinType) $ fi_tys fi
+ , case fi_flavor fi of
+ SynFamilyInst -> TypeInst . unLoc . synifyType WithinType $ fi_rhs fi
+ DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
)
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index a8a4f1c9..bf6436d1 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -91,6 +91,17 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ = []
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
+getInstLoc (TyFamInstD (TyFamInstDecl
+ -- Since CoAxioms' Names refer to the whole line for type family instances
+ -- in particular, we need to dig a bit deeper to pull out the entire
+ -- equation. This does not happen for data family instances, for some reason.
+ { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 03d463cb..a56759a5 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -23,6 +23,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Class
+import FamInstEnv
import FastString
import GHC
import GhcMonad (withSession)
@@ -64,16 +65,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
export {
expItemInstances =
case mb_info of
- Just (_, _, cls_instances, _fam_instances) ->
-{-
- let insts = map (first synifyInstHead) $ sortImage (first instHead)
- [ (instanceSig i, getName i) | i <- instances ]
--}
- let insts = map (first synifyInstHead) $ sortImage (first instHead) $
- filter (\((_,_,cls,tys),_) -> not $ isInstanceHidden expInfo cls tys)
- [ (instanceHead' i, getName i) | i <- cls_instances ]
- in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
- | (inst, name) <- insts ]
+ Just (_, _, cls_instances, fam_instances) ->
+ let fam_insts = [ (synifyFamInst i, n)
+ | i <- sortImage instFam fam_instances
+ , let n = lookupInstDoc (getName i) iface ifaceMap instIfaceMap
+ ]
+ cls_insts = [ (synifyInstHead i, lookupInstDoc n iface ifaceMap instIfaceMap)
+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
+ , (i@(_,_,cls,tys), n) <- sortImage (first instHead) is
+ , not $ isInstanceHidden expInfo cls tys
+ ]
+ in cls_insts ++ fam_insts
Nothing -> []
}
return export'
@@ -139,22 +141,27 @@ data SimpleType = SimpleType Name [SimpleType]
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
- where
- argCount (AppTy t _) = argCount t + 1
- argCount (TyConApp _ ts) = length ts
- argCount (FunTy _ _ ) = 2
- argCount (ForAllTy _ t) = argCount t
- argCount _ = 0
-
- simplify (ForAllTy _ t) = simplify t
- simplify (FunTy t1 t2) =
- SimpleType funTyConName [simplify t1, simplify t2]
- simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
- where (SimpleType s ts) = simplify t1
- simplify (TyVarTy v) = SimpleType (tyVarName v) []
- simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
- simplify (LitTy l) = SimpleTyLit l
+argCount :: Type -> Int
+argCount (AppTy t _) = argCount t + 1
+argCount (TyConApp _ ts) = length ts
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount _ = 0
+
+simplify :: Type -> SimpleType
+simplify (ForAllTy _ t) = simplify t
+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+ where (SimpleType s ts) = simplify t1
+simplify (TyVarTy v) = SimpleType (tyVarName v) []
+simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (LitTy l) = SimpleTyLit l
+
+-- Used for sorting
+instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
+instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
+ = (map argCount ts, n, map simplify ts, argCount t, simplify t)
-- sortImage f = sortBy (\x y -> compare (f x) (f y))
sortImage :: Ord b => (a -> b) -> [a] -> [a]
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 6e85ad16..cf5a3451 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -58,9 +58,10 @@ createInterface tm flags modMap instIfaceMap = do
mdl = ms_mod ms
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
+ !fam_instances = md_fam_insts md
!exportedNames = modInfoExports mi
- (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -80,9 +81,10 @@ createInterface tm flags modMap instIfaceMap = do
let declsWithDocs = topDecls group_
(decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
+ localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
+ ++ map getName fam_instances
- maps@(!docMap, !argMap, !subMap, !declMap) <-
+ maps@(!docMap, !argMap, !subMap, !declMap, _) <-
liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
let exports0 = fmap (reverse . map unLoc) mayExports
@@ -90,16 +92,14 @@ createInterface tm flags modMap instIfaceMap = do
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
- liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
-
warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
- instances instIfaceMap dflags
+ instIfaceMap dflags
- let !visibleNames = mkVisibleNames exportItems opts
+ let !visibleNames = mkVisibleNames maps exportItems opts
-- Measure haddock documentation coverage.
let prunedExportItems0 = pruneExportItems exportItems
@@ -138,6 +138,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceSubMap = subMap
, ifaceModuleAliases = aliases
, ifaceInstances = instances
+ , ifaceFamInstances = fam_instances
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
}
@@ -242,33 +243,33 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
-type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
+type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
-- | Create 'Maps' by looping through the declarations. For each declaration,
-- find its names, its subordinates, and its doc strings. Process doc strings
-- into 'Doc's.
mkMaps :: DynFlags
-> GlobalRdrEnv
- -> [ClsInst]
+ -> [Name]
-> [(LHsDecl Name, [HsDocString])]
-> ErrMsgM Maps
mkMaps dflags gre instances decls = do
(a, b, c, d) <- unzip4 <$> mapM mappings decls
- return (f a, f b, f c, f d)
+ return (f a, f b, f c, f d, instanceMap)
where
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
mappings (ldecl, docStrs) = do
- let decl = unLoc ldecl
+ let L l decl = ldecl
let declDoc strs m = do
doc <- processDocStrings dflags gre strs
m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
return (doc, m')
(doc, args) <- declDoc docStrs (typeDocs decl)
- let subs = subordinates decl
+ let subs = subordinates instanceMap decl
(subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
- let ns = names decl
+ let ns = names l decl
subNs = [ n | (n, _, _) <- subs ]
dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
@@ -282,11 +283,14 @@ mkMaps dflags gre instances decls = do
return (dm, am, sm, cm)
instanceMap :: Map SrcSpan Name
- instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
+ instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
- names :: HsDecl Name -> [Name]
- names (InstD (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ }))) = maybeToList (M.lookup l instanceMap) -- See note [2].
- names decl = getMainDeclBinder decl
+ names :: SrcSpan -> HsDecl Name -> [Name]
+ names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ where loc = case d of
+ TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ _ -> getInstLoc d
+ names _ decl = getMainDeclBinder decl
-- Note [2]:
------------
@@ -303,24 +307,29 @@ mkMaps dflags gre instances decls = do
-- | Get all subordinate declarations inside a declaration, and their docs.
-subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates (TyClD decl)
- | isClassDecl decl = classSubs
- | isDataDecl decl = dataSubs
+subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates instMap decl = case decl of
+ InstD (ClsInstD d) -> do
+ DataFamInstDecl { dfid_tycon = L l _
+ , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
+
+ InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
+ TyClD d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
+ _ -> []
where
- classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl
- , name <- getMainDeclBinder d, not (isValD d)
- ]
- dataSubs = constrs ++ fields
+ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+ , name <- getMainDeclBinder d, not (isValD d)
+ ]
+ dataSubs dd = constrs ++ fields
where
- cons = map unL $ (dd_cons (tcdDataDefn decl))
+ cons = map unL $ (dd_cons dd)
constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
| c <- cons ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map con_details cons
, ConDeclField n _ doc <- flds ]
-subordinates _ = []
-
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -390,38 +399,6 @@ sortByLoc :: [Located a] -> [Located a]
sortByLoc = sortBy (comparing getLoc)
-warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
-warnAboutFilteredDecls dflags mdl decls = do
- let modStr = moduleString mdl
- let typeInstances =
- nub (concat [[ unLoc (tfie_tycon (unLoc eqn))
- | L _ (InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn }))) <- decls ],
- [ unLoc (dfid_tycon d)
- | L _ (InstD (DataFamInstD { dfid_inst = d })) <- decls ],
- [ unLoc tc
- | L _ (TyClD (FamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _
- , fdLName = tc }))) <- decls ]])
-
- unless (null typeInstances) $
- tell [
- "Warning: " ++ modStr ++ ": Instances of type and data "
- ++ "families and equations of closed type families are not yet supported."
- ++ "Instances of the following families "
- ++ "will be filtered out:\n " ++ (intercalate ", "
- $ map (occNameString . nameOccName) typeInstances) ]
-
- let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD (ClsInstDecl
- { cid_poly_ty = i
- , cid_tyfam_insts = ats
- , cid_datafam_insts = adts }))) <- decls
- , not (null ats) || not (null adts) ]
-
- unless (null instances) $
- tell [
- "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
- ++ "These instances are affected:\n" ++ intercalate ", " instances ]
-
-
--------------------------------------------------------------------------------
-- Filtering of declarations
--
@@ -493,20 +470,16 @@ mkExportItems
-> [LHsDecl Name]
-> Maps
-> Maybe [IE Name]
- -> [ClsInst]
-> InstIfaceMap
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod warnings gre exportedNames decls0
- (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
+ modMap thisMod warnings gre exportedNames decls
+ (maps@(docMap, argMap, subMap, declMap, instMap)) optExports instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags warnings gre maps decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- decls = filter (not . isInstD . unLoc) decls0
-
-
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
lookupExport (IEThingAll t) = declWith t
@@ -585,7 +558,7 @@ mkExportItems
Nothing -> do
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
- let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
return [ mkExportDecl t decl (noDocForDecl, subs_) ]
Just iface ->
return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
@@ -710,7 +683,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
-- A type signature can have multiple names, like:
@@ -739,6 +712,10 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
fmap Just (hiValExportItem dflags name doc)
| otherwise = return Nothing
+ mkExportItem decl@(L _ (InstD d))
+ | Just name <- M.lookup (getInstLoc d) instMap =
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
+ return $ Just (ExportDecl decl doc subs [])
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
@@ -809,14 +786,17 @@ pruneExportItems = filter hasDoc
hasDoc _ = True
-mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
-mkVisibleNames exports opts
+mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames (_, _, _, _, instMap) exports opts
| OptHide `elem` opts = []
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
where
- exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
+ exportName e@ExportDecl {} = name ++ subs
where subs = map fst (expItemSubDocs e)
+ name = case unLoc $ expItemDecl e of
+ InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index b4a7e19a..de23e9b5 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -258,11 +258,14 @@ renameLContext (L loc context) = do
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (preds, className, types) = do
- preds' <- mapM renameType preds
+renameInstHead (className, types, rest) = do
className' <- rename className
types' <- mapM renameType types
- return (preds', className', types')
+ rest' <- case rest of
+ ClassInst cs -> ClassInst <$> mapM renameType cs
+ TypeInst ts -> TypeInst <$> renameType ts
+ DataInst dd -> DataInst <$> renameTyClD dd
+ return (className', types', rest')
renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 0a633ec0..0e7f83af 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -23,7 +23,7 @@ module Haddock.Types (
import Data.Foldable
import Data.Traversable
import Control.Exception
-import Control.Arrow
+import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Data.Typeable
import Data.Map (Map)
@@ -31,6 +31,7 @@ import qualified Data.Map as Map
import GHC hiding (NoLink)
import DynFlags (ExtensionFlag, Language)
import OccName
+import Outputable
import Control.Applicative (Applicative(..))
import Control.Monad (ap)
@@ -45,6 +46,7 @@ type DocMap a = Map Name (Doc a)
type ArgMap a = Map Name (Map Int (Doc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
+type InstMap = Map SrcSpan Name
type SrcMap = Map PackageId FilePath
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -112,6 +114,7 @@ data Interface = Interface
-- | Instances exported by the module.
, ifaceInstances :: ![ClsInst]
+ , ifaceFamInstances :: ![FamInst]
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
@@ -273,14 +276,23 @@ instance NamedThing DocName where
-- * Instances
-----------------------------------------------------------------------------
+-- | The three types of instances
+data InstType name
+ = ClassInst [HsType name] -- ^ Context
+ | TypeInst (HsType name) -- ^ Body (right-hand side)
+ | DataInst (TyClDecl name) -- ^ Data constructors
+
+instance OutputableBndr a => Outputable (InstType a) where
+ ppr (ClassInst a) = text "ClassInst" <+> ppr a
+ ppr (TypeInst a) = text "TypeInst" <+> ppr a
+ ppr (DataInst a) = text "DataInst" <+> ppr a
-- | An instance head that may have documentation.
type DocInstance name = (InstHead name, Maybe (Doc name))
-
--- | The head of an instance. Consists of a context, a class name and a list
--- of instance types.
-type InstHead name = ([HsType name], name, [HsType name])
+-- | The head of an instance. Consists of a class name, a list of parameters
+-- and an instance type
+type InstHead name = (name, [HsType name], InstType name)
-----------------------------------------------------------------------------
-- * Documentation comments
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 02:13:46 +0000