From e0718f203f2448ba2029e70d14aed075860b7fac Mon Sep 17 00:00:00 2001 From: nand Date: Tue, 4 Feb 2014 22:13:27 +0100 Subject: Add support for type/data families This adds support for type/data families with their respective instances, as well as closed type families and associated type/data families. Signed-off-by: Mateusz Kowalczyk --- src/Haddock/Backends/LaTeX.hs | 16 ++-- src/Haddock/Backends/Xhtml.hs | 1 + src/Haddock/Backends/Xhtml/Decl.hs | 42 ++++++----- src/Haddock/Backends/Xhtml/Layout.hs | 5 ++ src/Haddock/Convert.hs | 34 ++++++--- src/Haddock/GhcUtils.hs | 11 +++ src/Haddock/Interface/AttachInstances.hs | 57 ++++++++------- src/Haddock/Interface/Create.hs | 122 +++++++++++++------------------ src/Haddock/Interface/Rename.hs | 9 ++- src/Haddock/Types.hs | 22 ++++-- 10 files changed, 181 insertions(+), 138 deletions(-) (limited to 'src') 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 -- cgit v1.2.3