haddock-api 2.23.0 → 2.23.1
raw patch · 6 files changed
+70/−63 lines, 6 filesdep ~ghc
Dependency ranges changed: ghc
Files
- haddock-api.cabal +3/−3
- src/Haddock.hs +1/−1
- src/Haddock/Backends/Hyperlinker.hs +32/−17
- src/Haddock/Backends/Hyperlinker/Utils.hs +1/−1
- src/Haddock/Convert.hs +28/−37
- src/Haddock/Interface/Create.hs +5/−4
haddock-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api-version: 2.23.0+version: 2.23.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -43,7 +43,7 @@ -- this package typically supports only single major versions build-depends: base ^>= 4.13.0- , ghc ^>= 8.8+ , ghc ^>= 8.8 && >= 8.8.2 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2@@ -165,7 +165,7 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 8.8+ build-depends: ghc ^>= 8.8 && >= 8.8.2 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2
src/Haddock.hs view
@@ -432,7 +432,7 @@ when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-}- ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces+ ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return ()
src/Haddock/Backends/Hyperlinker.hs view
@@ -7,7 +7,7 @@ import Haddock.Types-import Haddock.Utils (writeUtf8File)+import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types@@ -18,12 +18,13 @@ import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..) )+import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache )+import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) import UniqSupply ( mkSplitUniqSupply ) @@ -32,27 +33,28 @@ -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source.-ppHyperlinkedSource :: FilePath -- ^ Output directory+ppHyperlinkedSource :: Verbosity+ -> FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO ()-ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do+ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir </> srcCssFile copyFile (libdir </> "html" </> highlightScript) $ srcdir </> highlightScript- mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces+ mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir </> hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface.-ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO ()-ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of+ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()+ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a'@@ -64,24 +66,37 @@ <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want- let mast | M.size asts == 1 = snd <$> M.lookupMin asts- | otherwise = M.lookup (mkFastString file) asts+ let fileFs = mkFastString file+ mast | M.size asts == 1 = snd <$> M.lookupMin asts+ | otherwise = M.lookup fileFs asts+ ast = fromMaybe (emptyHieAst fileFs) mast+ fullAst = recoverFullIfaceTypes df types ast tokens = parse df file rawSrc + -- Warn if we didn't find an AST, but there were still ASTs+ if M.null asts+ then pure ()+ else out verbosity verbose $ unwords [ "couldn't find ast for"+ , file, show (M.keys asts) ]+ -- Produce and write out the hyperlinked sources- case mast of- Just ast ->- let fullAst = recoverFullIfaceTypes df types ast- in writeUtf8File path . renderToString pretty . render' fullAst $ tokens- Nothing- | M.size asts == 0 -> return ()- | otherwise -> error $ unwords [ "couldn't find ast for"- , file, show (M.keys asts) ]+ writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return () where df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface)++ emptyNodeInfo = NodeInfo+ { nodeAnnotations = mempty+ , nodeType = []+ , nodeIdentifiers = mempty+ }+ emptyHieAst fileFs = Node+ { nodeInfo = emptyNodeInfo+ , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)+ , nodeChildren = []+ } -- | Name of CSS file in output directory. srcCssFile :: FilePath
src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -102,7 +102,7 @@ -- > hieAst -- -- However, this is very inefficient (both in time and space) because the--- mutliple calls to 'recoverFullType' don't share intermediate results. This+-- multiple calls to 'recoverFullType' don't share intermediate results. This -- function fixes that. recoverFullIfaceTypes :: DynFlags
src/Haddock/Convert.hs view
@@ -28,7 +28,6 @@ import Data.Either (lefts, rights) import DataCon import FamInstEnv-import FV import HsSyn import Name import NameSet ( emptyNameSet )@@ -45,8 +44,7 @@ import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique )-import Util ( chkAppend, compareLength, dropList, filterByList, filterOut- , splitAtList )+import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList ) import Var import VarSet @@ -150,8 +148,7 @@ = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only- annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)- args_types_only typats+ annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt@@ -162,7 +159,7 @@ , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where- fam_tvs = tyConVisibleTyVars tc+ args_poly = tyConArgsPolyKinded tc synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc })@@ -472,18 +469,27 @@ in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty --- | For every type variable in the input,--- report whether or not the tv is poly-kinded. This is used to eventually--- feed into 'annotHsType'.-mkIsPolyTvs :: [TyVar] -> [Bool]-mkIsPolyTvs = map is_poly_tv+-- | For every argument type that a type constructor accepts,+-- report whether or not the argument is poly-kinded. This is used to+-- eventually feed into 'annotThType'.+tyConArgsPolyKinded :: TyCon -> [Bool]+tyConArgsPolyKinded tc =+ map (is_poly_ty . tyVarKind) tc_vis_tvs+ ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs+ ++ repeat True where- is_poly_tv tv = not $+ is_poly_ty :: Type -> Bool+ is_poly_ty ty = not $ isEmptyVarSet $ filterVarSet isTyVar $- tyCoVarsOfType $- tyVarKind tv+ tyCoVarsOfType ty + tc_vis_tvs :: [TyVar]+ tc_vis_tvs = tyConVisibleTyVars tc++ tc_res_kind_vis_bndrs :: [TyCoBinder]+ tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc+ --states of what to do with foralls: data SynifyTypeState = WithinType@@ -539,7 +545,7 @@ = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc- , tyConArity tc == length tys+ , tyConArity tc == tys_len = noLoc $ HsTupleTy noExt (case sort of BoxedTuple -> HsBoxedTuple@@ -596,32 +602,17 @@ (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) - vis_tys = filterOutInvisibleTypes tc tys- binders = tyConBinders tc- res_kind = tyConResKind tc+ tys_len = length tys+ vis_tys = filterOutInvisibleTypes tc tys maybe_sig :: LHsType GhcRn -> LHsType GhcRn maybe_sig ty'- | needs_kind_sig+ | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' - needs_kind_sig :: Bool- needs_kind_sig- | GT <- compareLength tys binders- = False- | otherwise- = let (dropped_binders, remaining_binders)- = splitAtList tys binders- result_kind = mkTyConKind remaining_binders res_kind- result_vars = tyCoVarsOfType result_kind- dropped_vars = fvVarSet $- mapUnionFV injectiveVarsOfBinder dropped_binders-- in not (subVarSet result_vars dropped_vars)- synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1@@ -787,8 +778,8 @@ cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types ts' = map (synifyType WithinType vs) ts- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)+ annot_ts = zipWith3 annotHsType args_poly ts ts'+ args_poly = tyConArgsPolyKinded cls_tycon synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family@@ -827,8 +818,8 @@ ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)+ annot_ts = zipWith3 annotHsType args_poly ts ts'+ args_poly = tyConArgsPolyKinded fam_tc {- Note [Invariant: Never expand type synonyms]
src/Haddock/Interface/Create.hs view
@@ -83,8 +83,9 @@ (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings- , tcg_exports = all_exports+ , tcg_exports = all_exports0 }, md) = tm_internals_ tm+ all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre -- The 'pkgName' is necessary to decide what package to mention in "@since" -- annotations. Not having it is not fatal though.@@ -111,9 +112,9 @@ let declsWithDocs = topDecls group_ exports0 = fmap (map (first unLoc)) mayExports- exports- | OptIgnoreExports `elem` opts = Nothing- | otherwise = exports0+ (all_exports, exports)+ | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)+ | otherwise = (all_exports0, exports0) unrestrictedImportedMods -- module re-exports are only possible with