diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -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 diff --git a/resources/html/quick-jump.css b/resources/html/quick-jump.css --- a/resources/html/quick-jump.css +++ b/resources/html/quick-jump.css @@ -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 { diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -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) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -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"), diff --git a/src/Haddock/Backends/Hyperlinker/Parser.hs b/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -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 diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -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)) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -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 []) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -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 diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -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, diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -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. diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -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 diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -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 - diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -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 diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -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 diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -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)] diff --git a/src/Haddock/Interface/Json.hs b/src/Haddock/Interface/Json.hs --- a/src/Haddock/Interface/Json.hs +++ b/src/Haddock/Interface/Json.hs @@ -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 diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -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) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -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" diff --git a/src/Haddock/Interface/Specialize.hs b/src/Haddock/Interface/Specialize.hs --- a/src/Haddock/Interface/Specialize.hs +++ b/src/Haddock/Interface/Specialize.hs @@ -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" diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -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" diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -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 ] diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -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 "") 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 "") 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) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -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 diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -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