diff options
24 files changed, 640 insertions, 445 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index cea9c4bd..87761ff8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -61,6 +61,7 @@ library , exceptions , filepath , ghc-boot + , mtl , transformers hs-source-dirs: src diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3543d8e2..8bf932df 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -151,12 +151,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do sinceQual <- rightOrThrowE (sinceQualification flags) -- inject dynamic-too into flags before we proceed - flags' <- ghc flags $ do + flags'' <- ghc flags $ do df <- getDynFlags case lookup "GHC Dynamic" (compilerInfo df) of Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + flags' <- pure $ case optParCount flags'' of + Nothing -> flags'' + Just Nothing -> Flag_OptGhc "-j" : flags'' + Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags'' + -- bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 947ce51b..520b51f3 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -271,13 +271,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) -ppCtor dflags _dat subdocs con@(ConDeclGADT { }) - = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f +ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names + , con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty }) + = concatMap (lookupCon dflags subdocs) names ++ [typeSig] where - f = [typeSig name (getGADTConTypeG con)] - - typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty) - name = out dflags $ map unL $ getConNames con + typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty + name = out dflags $ map unL names + con_sig_ty = HsSig noExtField outer_bndrs theta_ty where + theta_ty = case mcxt of + Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + Nothing -> tau_ty + tau_ty = foldr mkFunTy res_ty $ + case args of PrefixConGADT pos_args -> map hsScaledThing pos_args + RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 2ba0bf52..d95c86b2 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,7 +39,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List (sort) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index fe97dee0..b7e2cafa 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -34,7 +34,6 @@ import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC -import GHC.Core.Class import GHC.Driver.Session import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder @@ -185,36 +184,6 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI --- ------------------------------------- - -getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn --- The full type of a GADT data constructor We really only get this in --- order to pretty-print it, and currently only in Haddock's code. So --- we are cavalier about locations and extensions, hence the --- 'undefined's -getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs - , con_mb_cxt = mcxt, con_g_args = args - , con_res_ty = res_ty }) - = noLoc (HsSig { sig_ext = noExtField - , sig_bndrs = outer_bndrs - , sig_body = theta_ty }) - where - theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) - | otherwise - = tau_ty - --- tau_ty :: LHsType DocNameI - tau_ty = case args of - RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - - -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) - -getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" - -- Should only be called on ConDeclGADT - ------------------------------------------------------------------------------- -- * Parenthesization @@ -433,14 +402,6 @@ modifySessionDynFlags f = do return () --- Extract the minimal complete definition of a Name, if one exists -minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) -minimalDef n = do - mty <- lookupGlobalName n - case mty of - Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c - _ -> return Nothing - ------------------------------------------------------------------------------- -- * DynFlags ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index be9bd09a..c557968f 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -29,7 +29,8 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface ( - processModules + plugin + , processModules ) where @@ -43,7 +44,7 @@ import Haddock.Types import Haddock.Utils import Control.Monad -import Control.Exception (evaluate) +import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Set as Set @@ -52,18 +53,24 @@ import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) import GHC.Driver.Env +import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) import GHC.Data.FastString (unpackFS) -import GHC.Tc.Types (tcg_rdr_env) +import GHC.Tc.Types (TcM, TcGblEnv(..)) +import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts) +import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs +import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), + defaultPlugin, keepRenamedSource) #if defined(mingw32_HOST_OS) import System.IO @@ -89,8 +96,14 @@ processModules verbosity modules flags extIfaces = do #endif out verbosity verbose "Creating interfaces..." - let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces - , iface <- ifInstalledIfaces ext ] + let + instIfaceMap :: InstIfaceMap + instIfaceMap = Map.fromList + [ (instMod iface, iface) + | ext <- extIfaces + , iface <- ifInstalledIfaces ext + ] + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames = @@ -126,93 +139,203 @@ processModules verbosity modules flags extIfaces = do createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) createIfaces verbosity modules flags instIfaceMap = do - -- Ask GHC to tell us what the module graph is + (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin + verbosity flags instIfaceMap + + let + installHaddockPlugin :: HscEnv -> HscEnv + installHaddockPlugin hsc_env = hsc_env + { + hsc_dflags = + gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy + , hsc_static_plugins = + haddockPlugin : hsc_static_plugins hsc_env + } + + -- Note that we would rather use withTempSession but as long as we + -- have the separate attachInstances step we need to keep the session + -- alive to be able to find all the instances. + modifySession installHaddockPlugin + targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - modGraph <- depanal [] False - -- Visit modules in that order - let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing - out verbosity normal "Haddock coverage:" - (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods - return (reverse ifaces, ms) - where - f (ifaces, ifaceMap, !ms) modSummary = do - x <- {-# SCC processModule #-} - withTimingD "processModule" (const ()) $ do - processModule verbosity modSummary flags ifaceMap instIfaceMap - return $ case x of - Just (iface, ms') -> ( iface:ifaces - , Map.insert (ifaceMod iface) iface ifaceMap - , unionModuleSet ms ms' ) - Nothing -> ( ifaces - , ifaceMap - , ms ) -- Boot modules don't generate ifaces. - - -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) -processModule verbosity modsum flags modMap instIfaceMap = do - out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum - - case isBootSummary modsum of - IsBoot -> - return Nothing - NotBoot -> do - unit_state <- hsc_units <$> getSession - out verbosity verbose "Creating interface..." - (interface, msgs) <- {-# SCC createIterface #-} - withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap - - -- We need to keep track of which modules were somehow in scope so that when - -- Haddock later looks for instances, it also looks in these modules too. - -- - -- See https://github.com/haskell/haddock/issues/469. - hsc_env <- getSession - let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - home_unit = hsc_home_unit hsc_env - !mods = mkModuleSet [ nameModule name - | gre <- globalRdrEnvElts new_rdr_env - , let name = gre_name gre - , nameIsFromExternalPackage home_unit name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - - liftIO $ mapM_ putStrLn (nub msgs) - dflags <- getDynFlags - let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int - modString = moduleString (ifaceMod interface) - coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString - header = case ifaceDoc interface of - Documentation Nothing _ -> False - _ -> True - undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface ] - where - formatName :: SrcSpan -> HsDecl GhcRn -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of - RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" - _ -> "" - - p [] = "" - p (x:_) = let n = pretty dflags x - ms = modString ++ "." - in if ms `isPrefixOf` n - then drop (length ms) n - else n - - when (OptHide `notElem` ifaceOptions interface) $ do - out verbosity normal coverageMsg - when (Flag_NoPrintMissingDocs `notElem` flags - && not (null undocumentedExports && header)) $ do - out verbosity normal " Missing documentation for:" - unless header $ out verbosity normal " Module header" - mapM_ (out verbosity normal . (" " ++)) undocumentedExports - interface' <- liftIO $ evaluate interface - return (Just (interface', mods)) + loadOk <- withTimingD "load" (const ()) $ + {-# SCC load #-} GHC.load LoadAllTargets + + case loadOk of + Failed -> + throwE "Cannot typecheck modules" + Succeeded -> do + modGraph <- GHC.getModuleGraph + ifaceMap <- liftIO getIfaces + moduleSet <- liftIO getModules + + let + ifaces :: [Interface] + ifaces = + [ Map.findWithDefault + (error "haddock:iface") + (ms_mod (emsModSummary ems)) + ifaceMap + | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing + ] + + return (ifaces, moduleSet) + + +-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock +-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to +-- parallelize the compilation process. +plugin + :: MonadIO m + => Verbosity + -> [Flag] + -> InstIfaceMap + -> m + ( + StaticPlugin -- the plugin to install with GHC + , m IfaceMap -- get the processed interfaces + , m ModuleSet -- get the loaded modules + ) +plugin verbosity flags instIfaceMap = liftIO $ do + ifaceMapRef <- newIORef Map.empty + moduleSetRef <- newIORef emptyModuleSet + + let + processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () + processTypeCheckedResult mod_summary tc_gbl_env + -- Don't do anything for hs-boot modules + | IsBoot <- isBootSummary mod_summary = + pure () + | otherwise = do + hsc_env <- getTopEnv + ifaces <- liftIO $ readIORef ifaceMapRef + (iface, modules) <- withTimingD "processModule" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env + + liftIO $ do + atomicModifyIORef' ifaceMapRef $ \xs -> + (Map.insert (ms_mod mod_summary) iface xs, ()) + + atomicModifyIORef' moduleSetRef $ \xs -> + (modules `unionModuleSet` xs, ()) + + staticPlugin :: StaticPlugin + staticPlugin = StaticPlugin + { + spPlugin = PluginWithArgs + { + paPlugin = defaultPlugin + { + renamedResultAction = keepRenamedSource + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do + processTypeCheckedResult mod_summary tc_gbl_env + pure tc_gbl_env + + } + , paArguments = [] + } + } + + pure + ( staticPlugin + , liftIO (readIORef ifaceMapRef) + , liftIO (readIORef moduleSetRef) + ) + + +processModule1 + :: Verbosity + -> [Flag] + -> IfaceMap + -> InstIfaceMap + -> HscEnv + -> ModSummary + -> TcGblEnv + -> TcM (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do + out verbosity verbose "Creating interface..." + + let + TcGblEnv { tcg_rdr_env } = tc_gbl_env + + unit_state = hsc_units hsc_env + + (!interface, messages) <- {-# SCC createInterface #-} + withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env + ifaces inst_ifaces + + -- We need to keep track of which modules were somehow in scope so that when + -- Haddock later looks for instances, it also looks in these modules too. + -- + -- See https://github.com/haskell/haddock/issues/469. + let + mods :: ModuleSet + !mods = mkModuleSet + [ nameModule name + | gre <- globalRdrEnvElts tcg_rdr_env + , let name = greMangledName gre + , nameIsFromExternalPackage (hsc_home_unit hsc_env) name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre -- In scope unqualified + ] + + liftIO $ mapM_ putStrLn (nub messages) + dflags <- getDynFlags + + let + (haddockable, haddocked) = + ifaceHaddockCoverage interface + + percentage :: Int + percentage = + round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) + + modString :: String + modString = moduleString (ifaceMod interface) + + coverageMsg :: String + coverageMsg = + printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString + + header :: Bool + header = case ifaceDoc interface of + Documentation Nothing _ -> False + _ -> True + + undocumentedExports :: [String] + undocumentedExports = + [ formatName s n + | ExportDecl { expItemDecl = L s n + , expItemMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface + ] + where + formatName :: SrcSpan -> HsDecl GhcRn -> String + formatName loc n = p (getMainDeclBinder n) ++ case loc of + RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ + show (srcSpanStartLine rss) ++ ")" + _ -> "" + + p :: Outputable a => [a] -> String + p [] = "" + p (x:_) = let n = pretty dflags x + ms = modString ++ "." + in if ms `isPrefixOf` n + then drop (length ms) n + else n + + when (OptHide `notElem` ifaceOptions interface) $ do + out verbosity normal coverageMsg + when (Flag_NoPrintMissingDocs `notElem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports + + pure (interface, mods) -------------------------------------------------------------------------------- @@ -241,4 +364,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 060bef91..76f1f765 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -18,42 +20,42 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- -module Haddock.Interface.Create (createInterface) where +module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) -import Haddock.Types +import Haddock.Types hiding (liftErrMsg) import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Data.Bifunctor +import Control.Monad.Reader +import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Control.Monad import Data.Traversable +import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.SourceFile +import GHC.Core.Class import GHC.Core.ConLike (ConLike(..)) -import GHC +import GHC hiding (lookupName) import GHC.Driver.Ppr -import GHC.Driver.Env import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State import GHC.Types.Name.Reader -import GHC.Tc.Types +import GHC.Tc.Types hiding (IfM) import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.SourceText @@ -64,175 +66,275 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.Module.Warnings --- | 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 - -> UnitState - -> [Flag] -- Boolean flags - -> IfaceMap -- Locally processed modules - -> InstIfaceMap -- External, already installed interfaces - -> ErrMsgGhc Interface -createInterface tm unit_state flags modMap instIfaceMap = do - - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - L _ hsm = parsedSource tm - !safety = modInfoSafe mi - mdl = ms_mod ms - sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) - is_sig = ms_hsc_src ms == HsigFile - dflags = ms_hspp_opts ms - !instances = modInfoInstances mi - !fam_instances = md_fam_insts md - !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl) - pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS - - (TcGblEnv { tcg_rdr_env = gre - , tcg_warns = warnings - , tcg_exports = all_exports - }, md) = tm_internals_ tm - - -- The 'pkgName' is necessary to decide what package to mention in "@since" - -- annotations. Not having it is not fatal though. - -- - -- Cabal can be trusted to pass the right flags, so this warning should be - -- mostly encountered when running Haddock outside of Cabal. - when (isNothing pkgName) $ - liftErrMsg $ tell [ "Warning: Package name is not available." ] - - -- The renamed source should always be available to us, but it's best - -- to be on the safe side. - (group_, imports, mayExports, mayDocHeader) <- - case renamedSource tm of - Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, [], Nothing, Nothing) - Just x -> return x - - opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl +newtype IfEnv m = IfEnv + { + -- | Lookup names in the enviroment. + ife_lookup_name :: Name -> m (Maybe TyThing) + } + + +-- | A monad in which we create Haddock interfaces. Not to be confused with +-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. +-- +-- In the past `createInterface` was running in the `Ghc` monad but proved hard +-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting +-- over the Ghc specific clarifies where side effects happen. +newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + + +deriving newtype instance Functor m => Functor (IfM m) +deriving newtype instance Applicative m => Applicative (IfM m) +deriving newtype instance Monad m => Monad (IfM m) +deriving newtype instance MonadIO m => MonadIO (IfM m) +deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) +deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m) + + +-- | Run an `IfM` action. +runIfM + -- | Lookup a global name in the current session. Used in cases + -- where declarations don't + :: (Name -> m (Maybe TyThing)) + -- | The action to run. + -> IfM m a + -- | Result and accumulated error/warning messages. + -> m (a, [ErrMsg]) +runIfM lookup_name action = do + let + if_env = IfEnv + { + ife_lookup_name = lookup_name + } + runWriterT (runReaderT (unIfM action) if_env) + + +liftErrMsg :: Monad m => ErrMsgM a -> IfM m a +liftErrMsg action = do + writer (runWriter action) + + +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- asks ife_lookup_name + lift $ lift (lookup_name name) + + +createInterface1 + :: MonadIO m + => [Flag] + -> UnitState + -> ModSummary + -> TcGblEnv + -> IfaceMap + -> InstIfaceMap + -> IfM m Interface +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do + + let + ModSummary + { + -- Cached flags from OPTIONS, INCLUDE and LANGUAGE + -- pragmas in the modules source code. Used to infer + -- safety of module. + ms_hspp_opts + , ms_location = ModLocation + { + ml_hie_file + } + } = mod_sum + + TcGblEnv + { + tcg_mod + , tcg_src + , tcg_semantic_mod + , tcg_rdr_env + , tcg_exports + , tcg_insts + , tcg_fam_insts + , tcg_warns + + -- Renamed source + , tcg_rn_imports + , tcg_rn_exports + , tcg_rn_decls + + , tcg_doc_hdr + } = tc_gbl_env + + dflags = ms_hspp_opts + + is_sig = tcg_src == HsigFile + + (pkg_name_fs, _) = + modulePackageInfo unit_state flags (Just tcg_mod) + + pkg_name :: Maybe Package + pkg_name = + let + unpack (PackageName name) = unpackFS name + in + fmap unpack pkg_name_fs + + fixities :: FixMap + fixities = case tcg_rn_decls of + Nothing -> mempty + Just dx -> mkFixMap dx + + -- Locations of all the TH splices + loc_splices :: [SrcSpan] + loc_splices = case tcg_rn_decls of + Nothing -> [] + Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] + + decls <- case tcg_rn_decls of + Nothing -> do + tell [ "Warning: Renamed source is not available" ] + pure [] + Just dx -> + pure (topDecls dx) + + -- Derive final options to use for haddocking this module + doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod + + let + -- All elements of an explicit export list, if present + export_list :: Maybe [(IE GhcRn, Avails)] + export_list + | OptIgnoreExports `elem` doc_opts = + Nothing + | Just rn_exports <- tcg_rn_exports = + Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ] + | otherwise = + Nothing + + -- All the exported Names of this module. + exported_names :: [Name] + exported_names = + concatMap availNamesWithSelectors tcg_exports + + -- Module imports of the form `import X`. Note that there is + -- a) no qualification and + -- b) no import list + imported_modules :: Map ModuleName [ModuleName] + imported_modules + | Just{} <- export_list = + unrestrictedModuleImports (map unLoc tcg_rn_imports) + | otherwise = + M.empty + + -- TyThings that have instances defined in this module + local_instances :: [Name] + local_instances = + [ name + | name <- map getName tcg_insts ++ map getName tcg_fam_insts + , nameIsLocalOrFrom tcg_semantic_mod name + ] + + -- Infer module safety + safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) -- Process the top-level module header documentation. - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - - exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 - - unrestrictedImportedMods - -- module re-exports are only possible with - -- explicit export list - | Just{} <- exports - = unrestrictedModuleImports (map unLoc imports) - | otherwise = M.empty - - fixMap = mkFixMap group_ - (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances - -- Locations of all TH splices - splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] - - warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - - maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) - - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - - -- The MAIN functionality: compute the export items which will - -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre - exportedNames decls maps fixMap unrestrictedImportedMods - splices exports all_exports instIfaceMap dflags - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- Measure haddock documentation coverage. - let prunedExportItems0 = pruneExportItems exportItems - !haddockable = 1 + length exportItems -- module + exports - !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - !coverage = (haddockable, haddocked) - - -- Prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems' - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems - !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - - let !aliases = mkAliasMap unit_state $ tm_renamed_source tm - - modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - - return $! Interface { - ifaceMod = mdl - , ifaceIsSig = is_sig - , ifaceOrigFilename = msHsFilePath ms - , ifaceInfo = info - , ifaceDoc = Documentation mbDoc modWarn - , ifaceRnDoc = Documentation Nothing Nothing - , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty - , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] - , ifaceExports = exportedNames - , ifaceVisibleExports = visibleNames - , ifaceDeclMap = declMap - , ifaceFixMap = fixMap - , ifaceModuleAliases = aliases - , ifaceInstances = instances - , ifaceFamInstances = fam_instances - , ifaceOrphanInstances = [] -- Filled in `attachInstances` - , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceHieFile = Just $ ml_hie_file $ ms_location ms - , ifaceDynFlags = dflags - } + (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name + tcg_rdr_env safety tcg_doc_hdr + + -- Warnings on declarations in this module + decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) + + -- Warning on the module header + mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) + + let + -- Warnings in this module and transitive warnings from dependend modules + warnings :: Map Name (Doc Name) + warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) + + maps@(!docs, !arg_docs, !decl_map, _) <- + liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls) + + export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod + warnings tcg_rdr_env exported_names (map fst decls) maps fixities + imported_modules loc_splices export_list tcg_exports inst_ifaces dflags + + let + visible_names :: [Name] + visible_names = mkVisibleNames maps export_items doc_opts + + -- Measure haddock documentation coverage. + pruned_export_items :: [ExportItem GhcRn] + pruned_export_items = pruneExportItems export_items + + !haddockable = 1 + length export_items -- module + exports + !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items + + coverage :: (Int, Int) + !coverage = (haddockable, haddocked) + + aliases :: Map Module ModuleName + aliases = mkAliasMap unit_state tcg_rn_imports + + return $! Interface + { + ifaceMod = tcg_mod + , ifaceIsSig = is_sig + , ifaceOrigFilename = msHsFilePath mod_sum + , ifaceHieFile = Just ml_hie_file + , ifaceInfo = info + , ifaceDoc = Documentation header_doc mod_warning + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = doc_opts + , ifaceDocMap = docs + , ifaceArgMap = arg_docs + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = if OptPrune `elem` doc_opts then + pruned_export_items else export_items + , ifaceRnExportItems = [] + , ifaceExports = exported_names + , ifaceVisibleExports = visible_names + , ifaceDeclMap = decl_map + , ifaceFixMap = fixities + , ifaceModuleAliases = aliases + , ifaceInstances = tcg_insts + , ifaceFamInstances = tcg_fam_insts + , ifaceOrphanInstances = [] -- Filled in attachInstances + , ifaceRnOrphanInstances = [] -- Filled in attachInstances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warnings + , 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 -- will go in 'ifaceModuleAliases'. -mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap state mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - SrcLoc.L _ alias <- ideclAs impDecl - return $ - (lookupModuleDyn state - -- TODO: This is supremely dodgy, because in general the - -- UnitId isn't going to look anything like the package - -- qualifier (even with old versions of GHC, the - -- IPID would be p-0.1, but a package qualifier never - -- has a version number it. (Is it possible that in - -- Haddock-land, the UnitIds never have version numbers? - -- I, ezyang, have not quite understand Haddock's package - -- identifier model.) - -- - -- Additionally, this is simulating some logic GHC already - -- has for deciding how to qualify names when it outputs - -- them to the user. We should reuse that information; - -- or at least reuse the renamed imports, which know what - -- they import! - (fmap Module.fsToUnit $ - fmap sl_fs $ ideclPkgQual impDecl) - (case ideclName impDecl of SrcLoc.L _ name -> name), - alias)) - impDecls +mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName +mkAliasMap state impDecls = + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + SrcLoc.L _ alias <- ideclAs impDecl + return $ + (lookupModuleDyn state + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! + (fmap Module.fsToUnit $ + fmap sl_fs $ ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls -- We want to know which modules are imported without any qualification. This -- way we can display module reexports more compactly. This mapping also looks @@ -293,7 +395,7 @@ mkWarningMap dflags warnings gre exps = case warnings of let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -457,7 +559,8 @@ mkFixMap group_ = -- 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 + :: Monad m + => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module @@ -474,7 +577,7 @@ mkExportItems -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem GhcRn] + -> IfM m [ExportItem GhcRn] mkExportItems is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports @@ -516,24 +619,39 @@ mkExportItems availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature - -> IfaceMap - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> [Name] -- exported names (orig) - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> AvailInfo - -> ErrMsgGhc [ExportItem GhcRn] + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> + return . Just $ classMinimalDef c + _ -> + return Nothing + + +availExportItem + :: forall m + . Monad m + => Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> IfM m [ExportItem GhcRn] availExportItem is_sig modMap thisMod semMod warnings exportedNames (docMap, argMap, declMap, _) fixMap splices instIfaceMap dflags availInfo = declWith availInfo where - declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ] + declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ] declWith avail = do let t = availName avail r <- findDecl avail @@ -570,7 +688,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t + mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -600,7 +718,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) - -> ErrMsgGhc [ ExportItem GhcRn ] + -> IfM m [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do -- bundled pattern synonyms only make sense if the declaration is @@ -645,7 +763,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of @@ -674,10 +792,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames n = availName avail m = nameModule n - findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)] findBundledPatterns avail = do patsyns <- for constructor_names $ \name -> do - mtyThing <- liftGhcToErrMsgGhc (lookupName name) + mtyThing <- lookupName name case mtyThing of Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name) @@ -693,16 +811,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail -availExportsDecl :: AvailInfo -> Bool -availExportsDecl (AvailTC ty_name names _) - | n : _ <- names = ty_name == n - | otherwise = False -availExportsDecl _ = True - availSubordinates :: AvailInfo -> [Name] -availSubordinates avail = - filter (/= availName avail) (availNamesWithSelectors avail) +availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail = @@ -715,9 +825,9 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) +hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do - mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + mayTyThing <- lookupName t case mayTyThing of Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] @@ -736,8 +846,9 @@ hiDecl dflags t = do -- It gets the type signature from GHC and that means it's not going to -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. -hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) +hiValExportItem + :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> IfM m (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -767,12 +878,14 @@ lookupDocs avail warnings docMap argMap = -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module. -moduleExport :: Module -- ^ Module A (identity, NOT semantic) - -> DynFlags -- ^ The flags used when typechecking A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> ModuleName -- ^ The exported module - -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport + :: Monad m + => Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> IfM m [ExportItem GhcRn] -- ^ Resulting export items moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. @@ -786,9 +899,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] + liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule (moduleUnit thisMod) expMod -- Identity module! @@ -814,22 +926,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: Bool -- is it a signature - -> IfaceMap - -> Maybe Package -- this package - -> Module -- this module - -> Module -- semantic module - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment - -> [Name] -- exported names (orig) - -> [LHsDecl GhcRn] -- renamed source declarations - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> InstIfaceMap - -> DynFlags - -> Avails - -> ErrMsgGhc [ExportItem GhcRn] +fullModuleContents + :: Monad m + => Bool -- is it a signature + -> IfaceMap + -> Maybe Package -- this package + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> IfM m [ExportItem GhcRn] fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2c06438f..87064a0f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -22,7 +23,7 @@ module Haddock.Interface.LexParseRn import GHC.Types.Avail import Control.Arrow import Control.Monad -import Data.List +import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) @@ -120,7 +121,7 @@ rename dflags gre = rn -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (greMangledName a)) -- There are multiple names available. gres -> ambiguous dflags x gres @@ -182,7 +183,7 @@ ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by hiding some imports.\n" ++ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index bfbdf392..14032d15 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,7 +29,6 @@ import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import GHC.HsToCore.Docs diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 72fcb79b..4455f0f8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -27,7 +27,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index eda40935..04189b99 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -24,6 +24,7 @@ module Haddock.Options ( optSourceCssFile, sourceUrls, wikiUrls, + optParCount, optDumpInterfaceFile, optShowInterfaceFile, optLaTeXStyle, @@ -45,11 +46,10 @@ import Data.Version import Control.Applicative import Distribution.Verbosity import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit ) +import GHC ( Module, moduleUnit ) import GHC.Unit.State import Haddock.Types import Haddock.Utils -import GHC.Unit.State import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -110,6 +110,7 @@ data Flag | Flag_PackageVersion String | Flag_Reexport String | Flag_SinceQualification String + | Flag_ParCount (Maybe Int) deriving (Eq, Show) @@ -221,7 +222,9 @@ options backwardsCompat = 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 ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n") + "load modules in parallel" ] @@ -304,10 +307,11 @@ optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] - optMathjax :: [Flag] -> Maybe String optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ] +optParCount :: [Flag] -> Maybe (Maybe Int) +optParCount flags = optLast [ n | Flag_ParCount n <- flags ] qualification :: [Flag] -> Either String QualOption qualification flags = diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 465d276e..bb76a1e9 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -3,6 +3,9 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -25,13 +28,16 @@ module Haddock.Types ( , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types + + -- $ Reexports + , runWriter + , tell ) where import Control.Exception -import Control.Arrow hiding ((<+>)) import Control.DeepSeq -import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) @@ -595,26 +601,7 @@ data SinceQual type ErrMsg = String -newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } - - -instance Functor ErrMsgM where - fmap f (Writer (a, msgs)) = Writer (f a, msgs) - -instance Applicative ErrMsgM where - pure a = Writer (a, []) - (<*>) = ap - -instance Monad ErrMsgM where - return = pure - m >>= k = Writer $ let - (a, w) = runWriter m - (b, w') = runWriter (k a) - in (b, w ++ w') - - -tell :: [ErrMsg] -> ErrMsgM () -tell w = Writer ((), w) +type ErrMsgM = Writer [ErrMsg] -- Exceptions @@ -637,34 +624,24 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } ---instance MonadIO ErrMsgGhc where --- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO ---er, implementing GhcMonad involves annoying ExceptionMonad and ---WarnLogMonad classes, so don't bother. -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = WriterGhc . return . runWriter --- for now, use (liftErrMsg . tell) for this ---tell :: [ErrMsg] -> ErrMsgGhc () ---tell msgs = WriterGhc $ return ( (), msgs ) +newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } -instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) +deriving newtype instance Functor ErrMsgGhc +deriving newtype instance Applicative ErrMsgGhc +deriving newtype instance Monad ErrMsgGhc +deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc +deriving newtype instance MonadIO ErrMsgGhc -instance Applicative ErrMsgGhc where - pure a = WriterGhc (return (a, [])) - (<*>) = ap -instance Monad ErrMsgGhc where - return = pure - m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (second (msgs1 ++)) (runWriterGhc (k a)) +runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg]) +runWriterGhc = runWriterT . unErrMsgGhc -instance MonadIO ErrMsgGhc where - liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = ErrMsgGhc . lift + +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = writer . runWriter ----------------------------------------------------------------------------- -- * Pass sensitive types diff --git a/haddock.cabal b/haddock.cabal index 7f2b5ee5..a56421e1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -84,7 +84,8 @@ executable haddock bytestring, parsec, text, - transformers + transformers, + mtl other-modules: Documentation.Haddock.Parser diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html index f087302c..9c5777d9 100644 --- a/html-test/ref/Bug574.html +++ b/html-test/ref/Bug574.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Bug679.html b/html-test/ref/Bug679.html index 9b7dcb86..ba34baa9 100644 --- a/html-test/ref/Bug679.html +++ b/html-test/ref/Bug679.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html index eb737305..d84577e7 100644 --- a/html-test/ref/Bug8.html +++ b/html-test/ref/Bug8.html @@ -89,7 +89,7 @@ ><p class="src" ><a id="v:-45--45--62-" class="def" >(-->)</a - > :: p1 -> p2 -> <a href="#" title="Bug8" + > :: p -> p -> <a href="#" title="Bug8" >Typ</a > <span class="fixity" >infix 9</span diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html index afa12e2b..7bae8016 100644 --- a/html-test/ref/BundledPatterns.html +++ b/html-test/ref/BundledPatterns.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" @@ -52,7 +52,7 @@ >data</span > <a href="#" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -82,7 +82,7 @@ >data</span > <a href="#" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -123,7 +123,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -146,7 +146,7 @@ > subscript starting from 0 and ending at <code ><code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >length</a ></code > - 1</code @@ -285,7 +285,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html index 48493cf9..d082175e 100644 --- a/html-test/ref/BundledPatterns2.html +++ b/html-test/ref/BundledPatterns2.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" @@ -52,7 +52,7 @@ >data</span > <a href="#" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -84,7 +84,7 @@ >data</span > <a href="#" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -125,7 +125,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -148,7 +148,7 @@ > subscript starting from 0 and ending at <code ><code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >length</a ></code > - 1</code @@ -283,7 +283,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html index f719d067..5075049f 100644 --- a/html-test/ref/QuasiExpr.html +++ b/html-test/ref/QuasiExpr.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html index edf14f4e..5bd7a476 100644 --- a/html-test/ref/QuasiQuote.html +++ b/html-test/ref/QuasiQuote.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/TH.html b/html-test/ref/TH.html index c8a7a6a3..767734c1 100644 --- a/html-test/ref/TH.html +++ b/html-test/ref/TH.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html index 4a69bd01..3a5d1b36 100644 --- a/html-test/ref/TH2.html +++ b/html-test/ref/TH2.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html index 96a4f060..056f958e 100644 --- a/html-test/ref/Threaded.html +++ b/html-test/ref/Threaded.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Ticket112.html b/html-test/ref/Ticket112.html index 4da5c459..28049b8f 100644 --- a/html-test/ref/Ticket112.html +++ b/html-test/ref/Ticket112.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" |