haddock-api 2.24.0 → 2.24.1
raw patch · 24 files changed
+644/−359 lines, 24 filesdep ~QuickCheckdep ~ghcdep ~haddock-library
Dependency ranges changed: QuickCheck, ghc, haddock-library
Files
- haddock-api.cabal +14/−8
- resources/html/quick-jump.css +2/−0
- src/Haddock.hs +1/−0
- src/Haddock/Backends/Hoogle.hs +14/−13
- src/Haddock/Backends/Hyperlinker/Parser.hs +3/−2
- src/Haddock/Backends/LaTeX.hs +11/−5
- src/Haddock/Backends/Xhtml.hs +15/−7
- src/Haddock/Backends/Xhtml/Decl.hs +7/−4
- src/Haddock/Backends/Xhtml/DocMarkup.hs +8/−7
- src/Haddock/Backends/Xhtml/Names.hs +6/−3
- src/Haddock/Convert.hs +8/−5
- src/Haddock/GhcUtils.hs +141/−40
- src/Haddock/Interface.hs +3/−2
- src/Haddock/Interface/AttachInstances.hs +2/−0
- src/Haddock/Interface/Create.hs +111/−65
- src/Haddock/Interface/Json.hs +162/−5
- src/Haddock/Interface/LexParseRn.hs +1/−1
- src/Haddock/Interface/Rename.hs +30/−7
- src/Haddock/Interface/Specialize.hs +7/−13
- src/Haddock/InterfaceFile.hs +38/−9
- src/Haddock/Options.hs +8/−2
- src/Haddock/Parser.hs +22/−12
- src/Haddock/Types.hs +26/−3
- src/Haddock/Utils.hs +4/−146
haddock-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api-version: 2.24.0+version: 2.24.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -46,7 +46,7 @@ build-depends: base ^>= 4.14.0 , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9- , haddock-library ^>= 1.9.0+ , haddock-library ^>= 1.10.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by@@ -63,11 +63,17 @@ hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances+ ghc-options: -funbox-strict-fields -O2+ -Wall+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wnoncanonical-monad-instances+ -Wmissing-home-modules+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates + exposed-modules: Documentation.Haddock @@ -168,10 +174,10 @@ build-depends: ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.12- , haddock-library ^>= 1.9.0+ , haddock-library ^>= 1.10.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8- , QuickCheck >= 2.11 && < 2.14+ , QuickCheck >= 2.11 && ^>= 2.14 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version
resources/html/quick-jump.css view
@@ -53,6 +53,8 @@ box-sizing: border-box; border: 0.05em solid #b2d5fb; background: #e8f3ff;+ max-height: 80%;+ overflow: scroll; } #search-form input + #search-results {
src/Haddock.hs view
@@ -42,6 +42,7 @@ import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_)+import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for)
src/Haddock/Backends/Hoogle.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle@@ -82,7 +83,7 @@ f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) f (HsParTy x a) = HsParTy x (g a) f (HsKindSig x a b) = HsKindSig x (g a) b- f (HsDocTy _ a _) = f $ unL a+ f (HsDocTy _ a _) = f $ unLoc a f x = x outHsType :: (OutputableBndrId p)@@ -215,7 +216,7 @@ ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :- concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)+ concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where -- GHC gives out "data Bar =", we want to delete the equals.@@ -244,22 +245,22 @@ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)- apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)+ funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y)+ apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with.- name = commaSeparate dflags . map unL $ getConNames con+ name = commaSeparate dflags . map unLoc $ getConNames con - resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat))+ resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat)) as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)- in apps (map reL (c : as))+ in apps (map noLoc (c : as)) tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n- tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { })@@ -267,8 +268,8 @@ where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)- name = out dflags $ map unL $ getConNames con+ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)+ name = out dflags $ map unLoc $ getConNames con ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String]@@ -298,7 +299,7 @@ mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where- getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)+ getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show@@ -326,7 +327,7 @@ markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),- markupModule = box (TagInline "a") . str,+ markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label), markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupBold = box (TagInline "b"),
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where import Control.Applicative ( Alternative(..) )@@ -175,7 +176,7 @@ ITdata -> TkKeyword ITdefault -> TkKeyword ITderiving -> TkKeyword- ITdo -> TkKeyword+ ITdo {} -> TkKeyword ITelse -> TkKeyword IThiding -> TkKeyword ITforeign -> TkKeyword@@ -208,7 +209,7 @@ ITcapiconv -> TkKeyword ITprimcallconv -> TkKeyword ITjavascriptcallconv -> TkKeyword- ITmdo -> TkKeyword+ ITmdo {} -> TkKeyword ITfamily -> TkKeyword ITrole -> TkKeyword ITgroup -> TkKeyword
src/Haddock/Backends/LaTeX.hs view
@@ -39,6 +39,7 @@ import Control.Monad import Data.Maybe import Data.List ( sort )+import Data.Void ( absurd ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation)@@ -254,7 +255,7 @@ , [DocName] -- names being declared ) declNames (L _ decl) = case decl of- TyClD _ d -> (empty, [tcdName d])+ TyClD _ d -> (empty, [tcdNameI d]) SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])@@ -530,7 +531,7 @@ tyvarNames :: LHsQTyVars DocNameI -> [Name]-tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit+tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX@@ -623,7 +624,7 @@ text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True | L _ decl <- ats- , let name = unL . fdLName $ decl+ , let name = unLoc . fdLName $ decl doc = lookupAnySubdoc name subdocs ] @@ -1080,7 +1081,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u-ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys@@ -1206,7 +1207,12 @@ , markupAppend = \l r v -> l v . r v , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i))- , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl)))+ , markupModule =+ \(ModLink m mLabel) v ->+ case mLabel of+ Just lbl -> inlineElem . tt $ lbl v empty+ Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m+ in (tt (text mdl))) , markupWarning = \p v -> p v , markupEmphasis = \p v -> inlineElem (emph (p v empty)) , markupBold = \p v -> inlineElem (bold (p v empty))
src/Haddock/Backends/Xhtml.hs view
@@ -222,10 +222,7 @@ ("Language", lg) ] ++ extsForm where- lg inf = case hmi_language inf of- Nothing -> Nothing- Just Haskell98 -> Just "Haskell98"- Just Haskell2010 -> Just "Haskell2010"+ lg inf = fmap show (hmi_language inf) multilineRow :: String -> [String] -> HtmlTable multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)@@ -294,6 +291,10 @@ ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)+ where+ -- Extract a module's short description.+ toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)+ toInstalledDescription = fmap mkMeta . hmi_description . instInfo ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html@@ -303,6 +304,7 @@ ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html+ppSignatureTree _ _ [] = mempty ppSignatureTree pkg qual ts = divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) @@ -402,7 +404,7 @@ exportSubs _ = [] exportName :: ExportItem DocNameI -> [IdP DocNameI]- exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)+ exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] @@ -668,16 +670,22 @@ where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es)- = ExportGroup lev (show n) doc : go (n+1) es+ = case collectAnchors doc of+ [] -> ExportGroup lev (show n) doc : go (n+1) es+ (a:_) -> ExportGroup lev a doc : go (n+1) es go n (other:es) = other : go n es + collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String]+ collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b+ collectAnchors (DocAName a) = [a]+ collectAnchors _ = [] processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc)- = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)+ = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y [])
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -32,6 +32,7 @@ import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe+import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted)@@ -491,7 +492,7 @@ +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats- , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] +++ , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] ++ -- ToDo: add associated type defaults @@ -535,6 +536,8 @@ -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + nm = tcdNameI decl+ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- Associated types@@ -543,7 +546,7 @@ <+> subDefaults (maybeToList defTys) | at <- ats- , let name = unL . fdLName $ unL at+ , let name = unLoc . fdLName $ unLoc at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name@@ -793,7 +796,7 @@ | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where- docname = tcdName dataDecl+ docname = tcdNameI dataDecl curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of@@ -1215,7 +1218,7 @@ ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts-ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -44,13 +44,14 @@ markupAppend = (+++), markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual,- markupModule = \m -> let (mdl,ref) = break (=='#') m- -- Accomodate for old style- -- foo\#bar anchors- mdl' = case reverse mdl of- '\\':_ -> init mdl- _ -> mdl- in ppModuleRef (mkModuleName mdl') ref,+ markupModule = \(ModLink m lbl) ->+ let (mdl,ref) = break (=='#') m+ -- Accomodate for old style+ -- foo\#bar anchors+ mdl' = case reverse mdl of+ '\\':_ -> init mdl+ _ -> mdl+ in ppModuleRef lbl (mkModuleName mdl') ref, markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupBold = strong,
src/Haddock/Backends/Xhtml/Names.hs view
@@ -186,9 +186,12 @@ << toHtml (moduleString mdl) -ppModuleRef :: ModuleName -> String -> Html-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]- << toHtml (moduleNameString mdl)+ppModuleRef :: Maybe Html -> ModuleName -> String -> Html+ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+ << toHtml (moduleNameString mdl)+ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+ << lbl+ -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used.
src/Haddock/Convert.hs view
@@ -612,11 +612,14 @@ in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' -synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1-synifyType _ vs (AppTy t1 t2) = let- s1 = synifyType WithinType vs t1- s2 = synifyType WithinType vs t2- in noLoc $ HsAppTy noExtField s1 s2+synifyType _ vs ty@(AppTy {}) = let+ (ty_head, ty_args) = splitAppTys ty+ ty_head' = synifyType WithinType vs ty_head+ ty_args' = map (synifyType WithinType vs) $+ filterOut isCoercionTy $+ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)+ ty_args+ in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1
src/Haddock/GhcUtils.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- |@@ -20,9 +21,11 @@ import Control.Arrow import Data.Char ( isSpace )+import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) +import BasicTypes ( PromotionFlag(..) ) import Exception import FV import Outputable ( Outputable, panic, showPpr )@@ -55,8 +58,7 @@ isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>- HsDecl p -> [IdP p]+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of@@ -163,18 +165,17 @@ where y = f x + -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName-hsTyVarNameI (UserTyVar _ (L _ n)) = n-hsTyVarNameI (KindedTyVar _ (L _ n) _) = n-hsTyVarNameI (XTyVarBndr nec) = noExtCon nec--hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName-hsLTyVarNameI = hsTyVarNameI . unLoc+-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)+hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n+hsTyVarBndrName (UserTyVar _ name) = unLoc name+hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name+hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name]@@ -219,6 +220,31 @@ -- Should only be called on ConDeclGADT getGADTConType (XConDecl nec) = noExtCon nec +getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]+getMainDeclBinderI (TyClD _ d) = [tcdNameI d]+getMainDeclBinderI (ValD _ d) =+ case collectHsBindBinders d of+ [] -> []+ (name:_) -> [name]+getMainDeclBinderI (SigD _ d) = sigNameNoLoc d+getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinderI _ = []++familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName+familyDeclLNameI (FamilyDecl { fdLName = n }) = n+familyDeclLNameI (XFamilyDecl nec) = noExtCon nec++tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName+tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd+tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln+tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln+tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln+tyClDeclLNameI (XTyClDecl nec) = noExtCon nec++tcdNameI :: TyClDecl DocNameI -> DocName+tcdNameI = unLoc . tyClDeclLNameI+ -- ------------------------------------- getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)@@ -253,6 +279,95 @@ getGADTConTypeG (XConDecl nec) = noExtCon nec +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn+-- Dubious, because the implicit binders are empty even+-- though the type might have free varaiables+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)+++addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn+-- Add the class context to a class-op signature+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))+ = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))+ -- The mkEmptySigWcType is suspicious+ where+ go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))+ = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+ , hst_bndrs = tvs, hst_body = go ty })+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))+ = L loc (HsQualTy { hst_xqual = noExtField+ , hst_ctxt = add_ctxt ctxt, hst_body = ty })+ go (L loc ty)+ = L loc (HsQualTy { hst_xqual = noExtField+ , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })++ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)+ add_ctxt (L loc preds) = L loc (extra_pred : preds)++addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine++lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]+lHsQTyVarsToTypes tvs+ = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))+ | tv <- hsQTvExplicit tvs ]+++--------------------------------------------------------------------------------+-- * Making abstract declarations+--------------------------------------------------------------------------------+++restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn+restrictTo names (L loc decl) = L loc $ case decl of+ TyClD x d | isDataDecl d ->+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })+ TyClD x d | isClassDecl d ->+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),+ tcdATs = restrictATs names (tcdATs d) })+ _ -> decl++restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })+ | DataType <- new_or_data+ = defn { dd_cons = restrictCons names cons }+ | otherwise -- Newtype+ = case restrictCons names cons of+ [] -> defn { dd_ND = DataType, dd_cons = [] }+ [con] -> defn { dd_cons = [con] }+ _ -> error "Should not happen"+restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec++restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]+ where+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =+ case con_args d of+ PrefixCon _ -> Just d+ RecCon fields+ | all field_avail (unLoc fields) -> Just d+ | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) })+ -- if we have *all* the field names available, then+ -- keep the record declaration. Otherwise degrade to+ -- a constructor declaration. This isn't quite right, but+ -- it's the best we can do.+ InfixCon _ _ -> Just d+ where+ field_avail :: LConDeclField GhcRn -> Bool+ field_avail (L _ (ConDeclField _ fs _ _))+ = all (\f -> extFieldOcc (unLoc f) `elem` names) fs+ field_avail (L _ (XConDeclField nec)) = noExtCon nec+ field_types flds = [ t | ConDeclField _ _ t _ <- flds ]++ keep _ = Nothing++restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))+++restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]+restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ]++ ------------------------------------------------------------------------------- -- * Parenthesization -------------------------------------------------------------------------------@@ -354,18 +469,6 @@ ---------------------------------------------------------------------------------- * Located-----------------------------------------------------------------------------------unL :: Located a -> a-unL (L _ x) = x---reL :: a -> Located a-reL = L undefined--------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -385,17 +488,17 @@ instance Parent (ConDecl GhcRn) where children con = case con_args con of- RecCon fields -> map (extFieldOcc . unL) $- concatMap (cd_fld_names . unL) (unL fields)+ RecCon fields -> map (extFieldOcc . unLoc) $+ concatMap (cd_fld_names . unLoc) (unLoc fields) _ -> [] instance Parent (TyClDecl GhcRn) where children d- | isDataDecl d = map unL $ concatMap (getConNames . unL)+ | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d =- map (unL . fdLName . unL) (tcdATs d) ++- [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]+ map (unLoc . fdLName . unLoc) (tcdATs d) +++ [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -405,13 +508,13 @@ familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]-familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)+familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl GhcRn -> [(Name, [Name])] families d- | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))+ | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] @@ -456,17 +559,16 @@ -- * DynFlags ------------------------------------------------------------------------------- --setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags-setObjectDir f d = d{ objectDir = Just f}-setHiDir f d = d{ hiDir = Just f}-setHieDir f d = d{ hieDir = Just f}-setStubDir f d = d{ stubDir = Just f- , includePaths = addGlobalInclude (includePaths d) [f] }- -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file- -- \#included from the .hc file when compiling with -fvia-C.-setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f-+-- TODO: use `setOutputDir` from GHC+setOutputDir :: FilePath -> DynFlags -> DynFlags+setOutputDir dir dynFlags =+ dynFlags { objectDir = Just dir+ , hiDir = Just dir+ , hieDir = Just dir+ , stubDir = Just dir+ , includePaths = addGlobalInclude (includePaths dynFlags) [dir]+ , dumpDir = Just dir+ } ------------------------------------------------------------------------------- -- * 'StringBuffer' and 'ByteString'@@ -683,4 +785,3 @@ go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty-
src/Haddock/Interface.hs view
@@ -43,6 +43,7 @@ import Haddock.Utils import Control.Monad+import Control.Monad.IO.Class ( liftIO ) import Control.Exception (evaluate) import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map@@ -110,7 +111,7 @@ let warnings = Flag_NoWarnings `notElem` flags dflags <- getDynFlags let (interfaces'', msgs) =- runWriter $ mapM (renameInterface dflags links warnings) interfaces'+ runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' liftIO $ mapM_ putStrLn msgs return (interfaces'', homeLinks)@@ -181,7 +182,7 @@ liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface- percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int+ percentage = div (haddocked * 100) haddockable modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of
src/Haddock/Interface/AttachInstances.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances
src/Haddock/Interface/Create.hs view
@@ -31,6 +31,7 @@ import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M+import qualified Data.Set as S import Data.Map (Map) import Data.List (find, foldl', sortBy) import Data.Maybe@@ -38,6 +39,7 @@ import Control.Applicative import Control.Monad import Data.Traversable+import GHC.Stack (HasCallStack) import Avail hiding (avail) import qualified Avail@@ -57,16 +59,21 @@ import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O +mkExceptionContext :: TypecheckedModule -> String+mkExceptionContext =+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'.-createInterface :: TypecheckedModule+createInterface :: HasCallStack+ => TypecheckedModule -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface-createInterface tm flags modMap instIfaceMap = do+createInterface tm flags modMap instIfaceMap =+ withExceptionContext (mkExceptionContext tm) $ do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm@@ -165,6 +172,18 @@ modWarn <- liftErrMsg (moduleWarning dflags gre warnings) + -- Prune the docstring 'Map's to keep only docstrings that are not private.+ --+ -- Besides all the names that GHC has told us this module exports, we also+ -- keep the docs for locally defined class instances. This is more names than+ -- we need, but figuring out which instances are fully private is tricky.+ --+ -- We do this pruning to avoid having to rename, emit warnings, and save+ -- docstrings which will anyways never be rendered.+ let !localVisibleNames = S.fromList (localInsts ++ exportedNames)+ !prunedDocMap = M.restrictKeys docMap localVisibleNames+ !prunedArgMap = M.restrictKeys argMap localVisibleNames+ return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig@@ -173,12 +192,12 @@ , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing , ifaceOptions = opts- , ifaceDocMap = docMap- , ifaceArgMap = argMap- , ifaceRnDocMap = M.empty- , ifaceRnArgMap = M.empty+ , ifaceDocMap = prunedDocMap+ , ifaceArgMap = prunedArgMap+ , ifaceRnDocMap = M.empty -- Filled in `renameInterface`+ , ifaceRnArgMap = M.empty -- Filled in `renameInterface` , ifaceExportItems = prunedExportItems- , ifaceRnExportItems = []+ , ifaceRnExportItems = [] -- Filled in `renameInterface` , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap@@ -194,7 +213,6 @@ , ifaceDynFlags = dflags } - -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This@@ -461,14 +479,14 @@ dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where- cons = map unL $ (dd_cons dd)- constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)+ cons = map unLoc $ (dd_cons dd)+ constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ]- fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)+ fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ]- derivs = [ (instName, [unL doc], M.empty)+ derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd@@ -585,13 +603,13 @@ -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterDecls = filter (isHandled . unL . fst)+filterDecls = filter (isHandled . unLoc . fst) where isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True- isHandled (SigD _ d) = isUserLSig (reL d)+ isHandled (SigD _ d) = isUserLSig (noLoc d) isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD {}) = True@@ -639,7 +657,8 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems- :: Bool -- is it a signature+ :: HasCallStack+ => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module@@ -677,7 +696,7 @@ return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $- findNamedDoc str [ unL d | d <- decls ] >>= \case+ findNamedDoc str [ unLoc d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr@@ -698,7 +717,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature+availExportItem :: HasCallStack+ => Bool -- is it a signature -> IfaceMap -> Module -- this module -> Module -- semantic module@@ -725,13 +745,13 @@ export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->- let declNames = getMainDeclBinder (unL decl)+ let declNames = getMainDeclBinder (unLoc decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames,- Just p <- find isExported (parents t $ unL decl) ->+ Just p <- find isExported (parents t $ unLoc decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++@@ -780,11 +800,24 @@ _ -> return [] - availExportDecl :: AvailInfo -> LHsDecl GhcRn+ -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails+ availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)+ availDecl declName parentDecl =+ case extractDecl declMap declName parentDecl of+ Right d -> pure d+ Left err -> do+ synifiedDeclOpt <- hiDecl dflags declName+ case synifiedDeclOpt of+ Just synifiedDecl -> pure synifiedDecl+ Nothing -> O.pprPanic "availExportItem" (O.text err)++ availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do+ extractedDecl <- availDecl (availName avail) decl+ -- bundled pattern synonyms only make sense if the declaration is -- exported (otherwise there would be nothing to bundle to) bundledPatSyns <- findBundledPatterns avail@@ -800,8 +833,7 @@ ] return [ ExportDecl {- expItemDecl = restrictTo (fmap fst subs)- (extractDecl declMap (availName avail) decl)+ expItemDecl = restrictTo (fmap fst subs) extractedDecl , expItemPats = bundledPatSyns , expItemMbDoc = doc , expItemSubDocs = subs@@ -811,18 +843,18 @@ } ] - | otherwise =- return [ ExportDecl {- expItemDecl = extractDecl declMap sub decl+ | otherwise = for subs $ \(sub, sub_doc) -> do+ extractedDecl <- availDecl sub decl++ return ( ExportDecl {+ expItemDecl = extractedDecl , expItemPats = [] , expItemMbDoc = sub_doc , expItemSubDocs = [] , expItemInstances = [] , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] , expItemSpliced = False- }- | (sub, sub_doc) <- subs- ]+ } ) exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet@@ -897,6 +929,7 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m +-- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t@@ -1040,20 +1073,31 @@ isSigD (L _ SigD{}) = True isSigD _ = False + -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...).-extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn+--+-- This function looks through the declarations in this module to try to find+-- the one with the right name.+extractDecl+ :: HasCallStack+ => DeclMap -- ^ all declarations in the file+ -> Name -- ^ name of the declaration to extract+ -> LHsDecl GhcRn -- ^ parent declaration+ -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl- | name `elem` getMainDeclBinder (unLoc decl) = decl+ | name `elem` getMainDeclBinder (unLoc decl) = pure decl | otherwise = case unLoc decl of- TyClD _ d@ClassDecl {} ->+ TyClD _ d@ClassDecl { tcdLName = L _ clsNm+ , tcdSigs = clsSigs+ , tcdATs = clsATs } -> let matchesMethod = [ lsig- | lsig <- tcdSigs d+ | lsig <- clsSigs , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig@@ -1061,51 +1105,54 @@ matchesAssociatedType = [ lfam_decl- | lfam_decl <- tcdATs d+ | lfam_decl <- clsATs , name == unLoc (fdLName (unLoc lfam_decl)) ] -- TODO: document fixity in case (matchesMethod, matchesAssociatedType) of- ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)- L pos sig = addClassContext n tyvar_names s0- in L pos (SigD noExtField sig)- (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl))+ ([s0], _) -> let tyvar_names = tyClDeclTyVars d+ L pos sig = addClassContext clsNm tyvar_names s0+ in pure (L pos (SigD noExtField sig))+ (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap -> extractDecl declMap name famInstDecl- _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"- O.$$ O.nest 4 (O.ppr d)- O.$$ O.text "Matches:"- O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))- TyClD _ d@DataDecl {} ->- let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))- in if isDataConName name- then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))- else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))+ _ -> Left (concat [ "Ambiguous decl for ", getOccString name+ , " in class ", getOccString clsNm ])++ TyClD _ d@DataDecl { tcdLName = L _ dataNm+ , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do+ let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))+ lsig <- if isDataConName name+ then extractPatternSyn name dataNm ty_args dataCons+ else extractRecSel name dataNm ty_args dataCons+ pure (SigD noExtField <$> lsig)+ TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =- FamEqn { feqn_tycon = L _ n- , feqn_pats = tys- , feqn_rhs = defn }}))) ->- if isDataConName name- then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)- else SigD noExtField <$> extractRecSel name n tys (dd_cons defn)+ FamEqn { feqn_tycon = L _ famName+ , feqn_pats = ty_args+ , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do+ lsig <- if isDataConName name+ then extractPatternSyn name famName ty_args dataCons+ else extractRecSel name famName ty_args dataCons+ pure (SigD noExtField <$> lsig) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =- FamEqn { feqn_rhs = dd+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons } } })) <- insts- , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))+ , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))- _ -> error "internal: extractDecl (ClsInstD)"+ _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts@@ -1117,16 +1164,15 @@ ] in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)- _ -> error "internal: extractDecl (ClsInstD)"- _ -> O.pprPanic "extractDecl" $- O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"- O.$$ O.nest 4 (O.ppr decl)+ _ -> Left "internal: extractDecl (ClsInstD)"+ _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn+extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of- [] -> error "extractPatternSyn: constructor pattern not found"- con:_ -> extract <$> con+ [] -> Left . O.showSDocUnsafe $+ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t+ con:_ -> pure (extract <$> con) where matches :: LConDecl GhcRn -> Bool matches (L _ con) = nm `elem` (unLoc <$> getConNames con)@@ -1157,13 +1203,13 @@ mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]- -> LSig GhcRn-extractRecSel _ _ _ [] = error "extractRecSel: selector not found"+ -> Either ErrMsg (LSig GhcRn)+extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->- L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
src/Haddock/Interface/Json.hs view
@@ -13,7 +13,6 @@ import Control.Arrow import Data.Map (Map)-import Data.Bifunctor import qualified Data.Map as Map import Haddock.Types@@ -58,14 +57,172 @@ jsonMDoc :: MDoc Name -> JsonDoc jsonMDoc MetaDoc{..} = jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])- , ("doc", jsonDoc _doc)+ , ("document", jsonDoc _doc) ] +showModName :: Wrap (ModuleName, OccName) -> String+showModName = showWrapped (moduleNameString . fst)++showName :: Wrap Name -> String+showName = showWrapped nameStableString++ jsonDoc :: Doc Name -> JsonDoc-jsonDoc doc = jsonString (show (bimap showModName showName doc))++jsonDoc DocEmpty = jsonObject+ [ ("tag", jsonString "DocEmpty") ]++jsonDoc (DocAppend x y) = jsonObject+ [ ("tag", jsonString "DocAppend")+ , ("first", jsonDoc x)+ , ("second", jsonDoc y)+ ]++jsonDoc (DocString s) = jsonObject+ [ ("tag", jsonString "DocString")+ , ("string", jsonString s)+ ]++jsonDoc (DocParagraph x) = jsonObject+ [ ("tag", jsonString "DocParagraph")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocIdentifier name) = jsonObject+ [ ("tag", jsonString "DocIdentifier")+ , ("name", jsonString (showName name))+ ]++jsonDoc (DocIdentifierUnchecked modName) = jsonObject+ [ ("tag", jsonString "DocIdentifierUnchecked")+ , ("modName", jsonString (showModName modName))+ ]++jsonDoc (DocModule (ModLink m _l)) = jsonObject+ [ ("tag", jsonString "DocModule")+ , ("string", jsonString m)+ ]++jsonDoc (DocWarning x) = jsonObject+ [ ("tag", jsonString "DocWarning")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocEmphasis x) = jsonObject+ [ ("tag", jsonString "DocEmphasis")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocMonospaced x) = jsonObject+ [ ("tag", jsonString "DocMonospaced")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocBold x) = jsonObject+ [ ("tag", jsonString "DocBold")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocUnorderedList xs) = jsonObject+ [ ("tag", jsonString "DocUnorderedList")+ , ("documents", jsonArray (fmap jsonDoc xs))+ ]++jsonDoc (DocOrderedList xs) = jsonObject+ [ ("tag", jsonString "DocOrderedList")+ , ("documents", jsonArray (fmap jsonDoc xs))+ ]++jsonDoc (DocDefList xys) = jsonObject+ [ ("tag", jsonString "DocDefList")+ , ("definitions", jsonArray (fmap jsonDef xys))+ ] where- showModName = showWrapped (moduleNameString . fst)- showName = showWrapped nameStableString+ jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)]++jsonDoc (DocCodeBlock x) = jsonObject+ [ ("tag", jsonString "DocCodeBlock")+ , ("document", jsonDoc x)+ ]++jsonDoc (DocHyperlink hyperlink) = jsonObject+ [ ("tag", jsonString "DocHyperlink")+ , ("hyperlink", jsonHyperlink hyperlink)+ ]+ where+ jsonHyperlink Hyperlink{..} = jsonObject+ [ ("hyperlinkUrl", jsonString hyperlinkUrl)+ , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel)+ ]++jsonDoc (DocPic picture) = jsonObject+ [ ("tag", jsonString "DocPic")+ , ("picture", jsonPicture picture)+ ]+ where+ jsonPicture Picture{..} = jsonObject+ [ ("pictureUrl", jsonString pictureUri)+ , ("pictureLabel", jsonMaybe jsonString pictureTitle)+ ]++jsonDoc (DocMathInline s) = jsonObject+ [ ("tag", jsonString "DocMathInline")+ , ("string", jsonString s)+ ]++jsonDoc (DocMathDisplay s) = jsonObject+ [ ("tag", jsonString "DocMathDisplay")+ , ("string", jsonString s)+ ]++jsonDoc (DocAName s) = jsonObject+ [ ("tag", jsonString "DocAName")+ , ("string", jsonString s)+ ]++jsonDoc (DocProperty s) = jsonObject+ [ ("tag", jsonString "DocProperty")+ , ("string", jsonString s)+ ]++jsonDoc (DocExamples examples) = jsonObject+ [ ("tag", jsonString "DocExamples")+ , ("examples", jsonArray (fmap jsonExample examples))+ ]+ where+ jsonExample Example{..} = jsonObject+ [ ("exampleExpression", jsonString exampleExpression)+ , ("exampleResult", jsonArray (fmap jsonString exampleResult))+ ]++jsonDoc (DocHeader header) = jsonObject+ [ ("tag", jsonString "DocHeader")+ , ("header", jsonHeader header)+ ]+ where+ jsonHeader Header{..} = jsonObject+ [ ("headerLevel", jsonInt headerLevel)+ , ("headerTitle", jsonDoc headerTitle)+ ]++jsonDoc (DocTable table) = jsonObject+ [ ("tag", jsonString "DocTable")+ , ("table", jsonTable table)+ ]+ where+ jsonTable Table{..} = jsonObject+ [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows))+ , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows))+ ]++ jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells)++ jsonTableCell TableCell{..} = jsonObject+ [ ("tableCellColspan", jsonInt tableCellColspan)+ , ("tableCellRowspan", jsonInt tableCellRowspan)+ , ("tableCellContents", jsonDoc tableCellContents)+ ]+ jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString
src/Haddock/Interface/LexParseRn.hs view
@@ -148,7 +148,7 @@ DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)- DocModule str -> pure (DocModule str)+ DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str)
src/Haddock/Interface/Rename.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename@@ -28,11 +29,21 @@ import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM)+import Data.List (intercalate) import qualified Data.Map as Map hiding ( Map )+import qualified Data.Set as Set import Prelude hiding (mapM) -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface-renameInterface dflags renamingEnv warnings iface =+-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to+-- 'DocName'.+--+-- What this really boils down to is: for each 'Name', figure out which of the+-- modules that export the name is the preferred place to link to.+--+-- The renamed output gets written into fields in the Haddock interface record+-- that were previously left empty.+renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface+renameInterface _dflags ignoredSymbols renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming@@ -67,8 +78,15 @@ -- Note that since the renamed AST represents equality constraints as -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to -- manually filter out 'eqTyCon_RDR' (aka @~@).- strings = [ pretty dflags n++ qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n++ ignoreSet = Set.fromList ignoredSymbols++ strings = [ qualifiedName n+ | n <- missingNames+ , not (qualifiedName n `Set.member` ignoreSet) , not (isSystemName n) , not (isBuiltInSyntax n) , Exact n /= eqTyCon_RDR@@ -80,7 +98,7 @@ unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++- unwords (" " : strings) ]+ intercalate "\n\t- " ("" : strings) ] return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap,@@ -128,6 +146,11 @@ (False,maps_to) -> (maps_to, (name :)) (True, maps_to) -> (maps_to, id) +-- | Look up a 'Name' in the renaming environment, but don't warn if you don't+-- find the name. Prefer to use 'lookupRn' whenever possible.+lookupRnNoWarn :: Name -> RnM DocName+lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id)+ -- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. -- Returns the renamed value along with a list of `Name`'s that could not be -- renamed because they weren't in the environment.@@ -313,7 +336,7 @@ = do { n' <- rename n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar x (L lv n') kind')) }-renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"+renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do@@ -512,7 +535,7 @@ renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl)-renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"+renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of@@ -532,7 +555,7 @@ lnames' <- mapM renameL lnames return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do- s' <- traverse renameL s+ s' <- traverse (traverse lookupRnNoWarn) s return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig"
src/Haddock/Interface/Specialize.hs view
@@ -3,12 +3,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize ( specializeInstHead ) where +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types @@ -56,13 +58,9 @@ -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn-specializeTyVarBndrs bndrs typs =- specialize $ zip bndrs' typs+specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where- bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs- bname (UserTyVar _ (L _ name)) = name- bname (KindedTyVar _ (L _ name) _) = name- bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"+ bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -212,7 +210,7 @@ | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx)- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)+ bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) -- | Make given type visually unambiguous.@@ -295,10 +293,10 @@ renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname renameBinder (KindedTyVar x lname lkind) = KindedTyVar x <$> located renameName lname <*> located renameType lkind-renameBinder (XTyVarBndr _) = error "haddock:renameBinder"+renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic.-renameName :: (Eq name, SetName name) => name -> Rename name name+renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of@@ -349,7 +347,3 @@ located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> IdP name-tyVarName (UserTyVar _ name) = unLoc name-tyVarName (KindedTyVar _ (L _ name) _) = name-tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
src/Haddock/InterfaceFile.hs view
@@ -21,9 +21,9 @@ import Haddock.Types-import Haddock.Utils hiding (out) import Control.Monad+import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Array import Data.IORef import Data.List (mapAccumR)@@ -45,7 +45,6 @@ import UniqSupply import Unique - data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, ifInstalledIfaces :: [InstalledInterface]@@ -68,6 +67,18 @@ binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story]+--+-- Breaking changes to the DocH type result in Haddock being unable to read+-- existing interfaces. This is especially painful for interfaces shipped+-- with GHC distributions since there is no easy way to regenerate them!+--+-- PR #1315 introduced a breaking change to the DocModule constructor. To+-- maintain backward compatibility we+--+-- Parse the old DocModule constructor format (tag 5) and parse the contained+-- string into a proper ModLink structure. When writing interfaces we exclusively+-- use the new DocModule format (tag 24) -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need@@ -83,10 +94,10 @@ -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811)-binaryInterfaceVersion = 36+binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16]-binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]+binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion] #else #error Unsupported GHC version #endif@@ -158,7 +169,7 @@ type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m+nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do@@ -443,6 +454,15 @@ label <- get bh return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where+ put_ bh (ModLink m label) = do+ put_ bh m+ put_ bh label+ get bh = do+ m <- get bh+ label <- get bh+ return (ModLink m label)+ instance Binary Picture where put_ bh (Picture uri title) = do put_ bh uri@@ -521,9 +541,6 @@ put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae- put_ bh (DocModule af) = do- putByte bh 5- put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag@@ -578,6 +595,10 @@ put_ bh (DocTable x) = do putByte bh 23 put_ bh x+ -- See note [The DocModule story]+ put_ bh (DocModule af) = do+ putByte bh 24+ put_ bh af get bh = do h <- getByte bh@@ -597,9 +618,13 @@ 4 -> do ae <- get bh return (DocIdentifier ae)+ -- See note [The DocModule story] 5 -> do af <- get bh- return (DocModule af)+ return $ DocModule ModLink+ { modLinkName = af+ , modLinkLabel = Nothing+ } 6 -> do ag <- get bh return (DocEmphasis ag)@@ -654,6 +679,10 @@ 23 -> do x <- get bh return (DocTable x)+ -- See note [The DocModule story]+ 24 -> do+ af <- get bh+ return (DocModule af) _ -> error "invalid binary data found in the interface file"
src/Haddock/Options.hs view
@@ -36,7 +36,8 @@ readIfaceArgs, optPackageName, optPackageVersion,- modulePackageInfo+ modulePackageInfo,+ ignoredSymbols ) where @@ -108,6 +109,7 @@ | Flag_PackageVersion String | Flag_Reexport String | Flag_SinceQualification String+ | Flag_IgnoreLinkSymbol String deriving (Eq, Show) @@ -219,7 +221,9 @@ Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") "version of the package being documented in usual x.y.z.w format", Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")- "package qualification of @since, one of\n'always' (default) or 'only-external'"+ "package qualification of @since, one of\n'always' (default) or 'only-external'",+ Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")+ "name of a symbol which does not trigger a warning in case of link issue" ] @@ -336,6 +340,8 @@ Left e -> throwE e Right v -> v +ignoredSymbols :: [Flag] -> [String]+ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ] ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
src/Haddock/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013,@@ -19,8 +20,10 @@ import DynFlags ( DynFlags ) import FastString ( fsLit )-import Lexer ( mkPState, unP, ParseResult(POk) )+import Lexer ( mkPState, unP, ParseResult(..) )+import OccName ( occNameString ) import Parser ( parseIdentifier )+import RdrName ( RdrName(Qual) ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) @@ -33,14 +36,21 @@ parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 =- let buffer = stringToStringBuffer str1- realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0- pstate = mkPState dflags buffer realSrcLc- (wrap,str1) = case str0 of- '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names- -> (Parenthesized, init s)- '`' : s@(_ : _) -> (Backticked, init s)- _ -> (Unadorned, str0)- in case unP parseIdentifier pstate of- POk _ (L _ name) -> Just (wrap (NsRdrName ns name))- _ -> Nothing+ case unP parseIdentifier (pstate str1) of+ POk _ (L _ name)+ -- Guards against things like 'Q.--', 'Q.case', etc.+ -- See https://github.com/haskell/haddock/issues/952 and Trac #14109+ | Qual _ occ <- name+ , PFailed{} <- unP parseIdentifier (pstate (occNameString occ))+ -> Nothing+ | otherwise+ -> Just (wrap (NsRdrName ns name))+ PFailed{} -> Nothing+ where+ realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0+ pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc+ (wrap,str1) = case str0 of+ '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names+ -> (Parenthesized, init s)+ '`' : s@(_ : _) -> (Backticked, init s)+ _ -> (Unadorned, str0)
src/Haddock/Types.hs view
@@ -35,9 +35,11 @@ import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data)+import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) +import Exception (ExceptionMonad(..), ghandle) import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt@@ -498,6 +500,9 @@ instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where+ rnf (ModLink a b) = a `deepseq` b `deepseq` ()+ instance NFData Picture where rnf (Picture a b) = a `deepseq` b `deepseq` () @@ -648,17 +653,28 @@ -- | Haddock's own exception type.-data HaddockException = HaddockException String deriving Typeable+data HaddockException+ = HaddockException String+ | WithContext [String] SomeException+ deriving Typeable instance Show HaddockException where show (HaddockException str) = str-+ show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se] throwE :: String -> a instance Exception HaddockException throwE str = throw (HaddockException str) +withExceptionContext :: ExceptionMonad m => String -> m a -> m a+withExceptionContext ctxt =+ ghandle (\ex ->+ case ex of+ HaddockException e -> throw $ WithContext [ctxt] (toException ex)+ WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se+ ) .+ ghandle (throw . WithContext [ctxt]) -- In "Haddock.Interface.Create", we need to gather -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,@@ -693,6 +709,12 @@ instance MonadIO ErrMsgGhc where liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +instance ExceptionMonad ErrMsgGhc where+ gcatch act hand = WriterGhc $+ runWriterGhc act `gcatch` (runWriterGhc . hand)+ gmask act = WriterGhc $ gmask $ \mask ->+ runWriterGhc $ act (WriterGhc . mask . runWriterGhc)+ ----------------------------------------------------------------------------- -- * Pass sensitive types -----------------------------------------------------------------------------@@ -713,7 +735,7 @@ type instance XParTy DocNameI = NoExtField type instance XIParamTy DocNameI = NoExtField type instance XKindSig DocNameI = NoExtField-type instance XSpliceTy DocNameI = NoExtField+type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` type instance XDocTy DocNameI = NoExtField type instance XBangTy DocNameI = NoExtField type instance XRecTy DocNameI = NoExtField@@ -770,6 +792,7 @@ type instance XSynDecl DocNameI = NoExtField type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon+type instance XXTyClDecl DocNameI = NoExtCon type instance XHsIB DocNameI _ = NoExtField type instance XHsWC DocNameI _ = NoExtField
src/Haddock/Utils.hs view
@@ -13,15 +13,9 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( - -- * Misc utilities- restrictTo, emptyHsQTvs,- toDescription, toInstalledDescription,- mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,- -- * Filename utilities moduleHtmlFile, moduleHtmlFile', contentsHtmlFile, indexHtmlFile, indexJsonFile,- moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, haddockJsFile, jsQuickJumpFile, quickJumpCssFile,@@ -32,7 +26,7 @@ makeAnchorId, -- * Miscellaneous utilities- getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,+ getProgramName, bye, die, escapeStr, writeUtf8File, withTempDir, -- * HTML cross reference mapping@@ -45,9 +39,6 @@ replace, spanWith, - -- * MTL stuff- MonadIO(..),- -- * Logging parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out,@@ -61,23 +52,21 @@ import Haddock.Types import Haddock.GhcUtils -import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Control.Monad ( liftM )+import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf )-import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit import System.Directory ( createDirectory, removeDirectoryRecursive )-import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )+import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -85,9 +74,7 @@ import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) ) - -------------------------------------------------------------------------------- -- * Logging --------------------------------------------------------------------------------@@ -129,117 +116,14 @@ -------------------------------------------------------------------------------- --- | Extract a module's short description.-toDescription :: Interface -> Maybe (MDoc Name)-toDescription = fmap mkMeta . hmi_description . ifaceInfo ---- | Extract a module's short description.-toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)-toInstalledDescription = fmap mkMeta . hmi_description . instInfo- mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn--- Dubious, because the implicit binders are empty even--- though the type might have free varaiables-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)--addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn--- Add the class context to a class-op signature-addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))- -- The mkEmptySigWcType is suspicious- where- go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))- = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField- , hst_bndrs = tvs, hst_body = go ty })- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))- = L loc (HsQualTy { hst_xqual = noExtField- , hst_ctxt = add_ctxt ctxt, hst_body = ty })- go (L loc ty)- = L loc (HsQualTy { hst_xqual = noExtField- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })-- extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)- add_ctxt (L loc preds) = L loc (extra_pred : preds)--addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine--lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]-lHsQTyVarsToTypes tvs- = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))- | tv <- hsQTvExplicit tvs ]- ----------------------------------------------------------------------------------- * Making abstract declarations------------------------------------------------------------------------------------restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn-restrictTo names (L loc decl) = L loc $ case decl of- TyClD x d | isDataDecl d ->- TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })- TyClD x d | isClassDecl d ->- TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),- tcdATs = restrictATs names (tcdATs d) })- _ -> decl--restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })- | DataType <- new_or_data- = defn { dd_cons = restrictCons names cons }- | otherwise -- Newtype- = case restrictCons names cons of- [] -> defn { dd_ND = DataType, dd_cons = [] }- [con] -> defn { dd_cons = [con] }- _ -> error "Should not happen"-restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"--restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]- where- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =- case con_args d of- PrefixCon _ -> Just d- RecCon fields- | all field_avail (unL fields) -> Just d- | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })- -- if we have *all* the field names available, then- -- keep the record declaration. Otherwise degrade to- -- a constructor declaration. This isn't quite right, but- -- it's the best we can do.- InfixCon _ _ -> Just d- where- field_avail :: LConDeclField GhcRn -> Bool- field_avail (L _ (ConDeclField _ fs _ _))- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs- field_avail (L _ (XConDeclField nec)) = noExtCon nec- field_types flds = [ t | ConDeclField _ _ t _ <- flds ]-- keep _ = Nothing--restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))---restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]--emptyHsQTvs :: LHsQTyVars GhcRn--- This function is here, rather than in HsTypes, because it *renamed*, but--- does not necessarily have all the rigt kind variables. It is used--- in Haddock just for printing, so it doesn't matter-emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs"- , hsq_explicit = [] }----------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -266,13 +150,6 @@ indexJsonFile = "doc-index.json" --moduleIndexFrameName, mainFrameName, synopsisFrameName :: String-moduleIndexFrameName = "modules"-mainFrameName = "main"-synopsisFrameName = "synopsis"-- subIndexHtmlFile :: String -> String subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" where b | all isAlpha ls = ls@@ -346,7 +223,7 @@ getProgramName :: IO String-getProgramName = liftM (`withoutSuffix` ".bin") getProgName+getProgramName = fmap (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str@@ -354,25 +231,6 @@ bye :: String -> IO a bye s = putStr s >> exitSuccess---dieMsg :: String -> IO ()-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)---noDieMsg :: String -> IO ()-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)---mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]-mapSnd _ [] = []-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs---mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)-mapMaybeM _ Nothing = return Nothing-mapMaybeM f (Just a) = liftM Just (f a)- escapeStr :: String -> String escapeStr = escapeURIString isUnreserved