diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index f3dbe2e2c4d1592cd5fe1e792ab1a7e28b89ce9d..2389540dd6161df82eb9905de5604d925b453834 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -60,6 +60,7 @@ library
, exceptions
, filepath
, ghc-boot
+ , mtl
, transformers
hs-source-dirs: src
@@ -192,6 +193,7 @@ test-suite spec
, exceptions
, filepath
, ghc-boot
+ , mtl
, transformers
build-tool-depends:
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 10725ee5db183ab89d83e7ecf23cbd5dacf7486c..d12b79ad5f5151471dae3ac38df816d08ec0c590 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -30,9 +30,7 @@ import GHC.Utils.Outputable ( Outputable, panic, showPpr )
import GHC.Types.Basic (PromotionFlag(..))
import GHC.Types.Name
import GHC.Unit.Module
-import GHC.Driver.Types
import GHC
-import GHC.Core.Class
import GHC.Driver.Session
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
@@ -526,14 +524,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
-------------------------------------------------------------------------------
@@ -766,4 +756,3 @@ defaultRuntimeRepVars = go emptyVarEnv
go _ ty@(LitTy {}) = ty
go _ ty@(CoercionTy {}) = ty
-
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 7bd092da393897990d98243fb10108bc707c62d0..dab84bebf8eedbbb74a1daffc2082f4052875548 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -55,10 +55,11 @@ import GHC hiding (verbosity)
import GHC.Data.Graph.Directed
import GHC.Driver.Session hiding (verbosity)
import GHC.Driver.Types (isBootSummary)
-import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
+import GHC.Driver.Monad (modifySession)
import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (TcGblEnv(..))
-import GHC.Tc.Utils.Monad (getTopEnv)
+import GHC.Tc.Types (TcM, TcGblEnv(..))
+import GHC.Tc.Utils.Monad (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)
@@ -200,7 +201,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do
moduleSetRef <- newIORef emptyModuleSet
let
- processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc ()
+ processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
processTypeCheckedResult mod_summary tc_gbl_env
-- Don't do anything for hs-boot modules
| IsBoot <- isBootSummary mod_summary =
@@ -225,11 +226,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do
paPlugin = defaultPlugin
{
renamedResultAction = keepRenamedSource
- , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do
- session <- getTopEnv >>= liftIO . newIORef
- liftIO $ reflectGhc
- (processTypeCheckedResult mod_summary tc_gbl_env)
- (Session session)
+ , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+ processTypeCheckedResult mod_summary tc_gbl_env
pure tc_gbl_env
}
@@ -244,7 +242,6 @@ plugin verbosity flags instIfaceMap = liftIO $ do
)
-
processModule1
:: Verbosity
-> [Flag]
@@ -252,7 +249,7 @@ processModule1
-> InstIfaceMap
-> ModSummary
-> TcGblEnv
- -> Ghc (Interface, ModuleSet)
+ -> TcM (Interface, ModuleSet)
processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
out verbosity verbose "Creating interface..."
@@ -260,15 +257,13 @@ processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
TcGblEnv { tcg_rdr_env } = tc_gbl_env
(!interface, messages) <- {-# SCC createInterface #-}
- withTimingD "createInterface" (const ()) $
- runWriterGhc $ createInterface1 flags mod_summary
- tc_gbl_env ifaces inst_ifaces
+ withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+ createInterface1 flags 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.
-
dflags <- getDynFlags
let
mods :: ModuleSet
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9f177ca8cd8e9e835d433043f7620dbcc62aef98..308d7d4165bbd52e813346a8887c31527b7b5f8c 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, NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -18,25 +20,24 @@
-- which creates a Haddock 'Interface' from the typechecking
-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface, createInterface1) 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 Control.Monad.IO.Class
-import Data.Bifunctor
+import Control.Monad.Catch
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict hiding (tell)
import Data.Bitraversable
import qualified Data.Map as M
-import qualified Data.Set as S
import Data.Map (Map)
import Data.List (find, foldl')
import Data.Maybe
-import Control.Monad
import Data.Traversable
import GHC.Stack (HasCallStack)
@@ -44,34 +45,103 @@ 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
+-- <<<<<<< HEAD
import qualified GHC.Types.SrcLoc as SrcLoc
+import GHC.Core.Class ( ClassMinimalDef, classMinimalDef )
import GHC.Core.ConLike (ConLike(..))
-import GHC
+import GHC hiding ( lookupName )
import GHC.Driver.Types
+-- =======
+-- 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 hiding (lookupName)
+-- import GHC.Driver.Ppr
+-- >>>>>>> 703e5f02... Abstract Monad for interface creation
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 ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified GHC.Utils.Outputable as O
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
-mkExceptionContext :: TypecheckedModule -> String
+
+mkExceptionContext :: ModSummary -> String
mkExceptionContext =
- ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name
+
+
+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)
+deriving newtype instance (MonadThrow m) => MonadThrow (IfM m)
+deriving newtype instance (MonadCatch m) => MonadCatch (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
- :: [Flag]
+ :: (MonadIO m, MonadCatch m)
+ => [Flag]
-> ModSummary
-> TcGblEnv
-> IfaceMap
-> InstIfaceMap
- -> ErrMsgGhc Interface
-createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
+ -> IfM m Interface
+createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces =
+ withExceptionContext (mkExceptionContext mod_sum) $ do
let
ModSummary
@@ -132,7 +202,7 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
decls <- case tcg_rn_decls of
Nothing -> do
- liftErrMsg $ tell [ "Warning: Renamed source is not available" ]
+ tell [ "Warning: Renamed source is not available" ]
pure []
Just dx ->
pure (topDecls dx)
@@ -152,9 +222,16 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
Nothing
-- All the exported Names of this module.
+ actual_exports :: [AvailInfo]
+ actual_exports
+ | OptIgnoreExports `elem` doc_opts =
+ gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env
+ | otherwise =
+ tcg_exports
+
exported_names :: [Name]
exported_names =
- concatMap availNamesWithSelectors tcg_exports
+ concatMap availNamesWithSelectors actual_exports
-- Module imports of the form `import X`. Note that there is
-- a) no qualification and
@@ -197,7 +274,7 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
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
+ imported_modules loc_splices export_list actual_exports inst_ifaces dflags
let
visible_names :: [Name]
@@ -248,156 +325,6 @@ createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = do
}
--- | 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 :: HasCallStack
- => TypecheckedModule
- -> [Flag] -- Boolean flags
- -> IfaceMap -- Locally processed modules
- -> InstIfaceMap -- External, already installed interfaces
- -> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap =
- withExceptionContext (mkExceptionContext tm) $ 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 dflags flags (Just mdl)
- pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
-
- (TcGblEnv { tcg_rdr_env = gre
- , tcg_warns = warnings
- , 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.
- --
- -- 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
-
- -- 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
- (all_exports, exports)
- | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
- | otherwise = (all_exports0, 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 fam_instances
- ++ map getName 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 (unitState dflags) imports
- 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
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = prunedDocMap
- , ifaceArgMap = prunedArgMap
- , ifaceRnDocMap = M.empty -- Filled in `renameInterface`
- , ifaceRnArgMap = M.empty -- Filled in `renameInterface`
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = [] -- Filled in `renameInterface`
- , 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
- }
-
-
-- | 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
@@ -652,7 +579,7 @@ 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
- :: HasCallStack
+ :: (Monad m)
=> Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
@@ -670,7 +597,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
@@ -712,25 +639,39 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: HasCallStack
- => 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
@@ -767,7 +708,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_
@@ -796,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
- availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+ availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl declName parentDecl =
case extractDecl declMap declName parentDecl of
Right d -> pure d
@@ -808,7 +749,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
extractedDecl <- availDecl (availName avail) decl
@@ -854,7 +795,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
@@ -883,10 +824,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)
@@ -925,9 +866,9 @@ semToIdMod this_uid m
| otherwise = m
-- | Reify a declaration from the GHC internal 'TyThing' representation.
-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]
@@ -946,8 +887,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
@@ -977,12 +919,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.
@@ -996,9 +940,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!
@@ -1024,22 +967,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 87210273c8335f403793ed8e84f5448277bcc55a..2ada67d13d8f2a17f29ec79ac47317531f91e5e5 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 #-}
-----------------------------------------------------------------------------
-- |
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b86bb4fb2da00320d7a9f63b1b2d49b0fbc6afbf..b24079456aa4173bd2d2b59f18f48f8420c111f5 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -47,9 +47,10 @@ import Data.Version
import Control.Applicative
import GHC.Data.FastString
import GHC ( DynFlags, Module, moduleUnit, unitState )
+import GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion )
+import GHC.Unit.State ( lookupUnit )
import Haddock.Types
import Haddock.Utils
-import GHC.Unit.State
import System.Console.GetOpt
import qualified Text.ParserCombinators.ReadP as RP
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53d01565d48eaaf6af5ef8d6c2d0219eb6e3f46e..e38568ab0f65ed0e1f7b53f3fb981571ded80f9a 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,14 +28,17 @@ module Haddock.Types (
, HsDocString, LHsDocString
, Fixity(..)
, module Documentation.Haddock.Types
+
+ -- $ Reexports
+ , runWriter
+ , tell
) where
-import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Control.Exception (throw)
-import Control.Monad (ap)
import Control.Monad.Catch
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)
@@ -628,26 +634,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
@@ -681,40 +668,30 @@ withExceptionContext ctxt =
-- @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
instance MonadThrow ErrMsgGhc where
- throwM e = WriterGhc (throwM e)
+ throwM e = ErrMsgGhc (throwM e)
instance MonadCatch ErrMsgGhc where
- catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f))
+ catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f))
-----------------------------------------------------------------------------
-- * Pass sensitive types
diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.parsed b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
index 39adab641990411acdf2da098e05c70adc2a5afd..fbef2bf3fe66259566417b3256dcb64b347a177b 100644
--- a/haddock-library/fixtures/examples/linkInlineMarkup.parsed
+++ b/haddock-library/fixtures/examples/linkInlineMarkup.parsed
@@ -3,6 +3,7 @@ DocParagraph
(DocString "Bla ")
(DocHyperlink
Hyperlink
- {hyperlinkLabel = Just (DocAppend (DocString "link ")
- (DocEmphasis (DocString "emphasized"))),
+ {hyperlinkLabel = Just
+ (DocAppend
+ (DocString "link ") (DocEmphasis (DocString "emphasized"))),
hyperlinkUrl = "http://example.com"}))
diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html
index 736fb2ad4485d826da75a60e7dce4f722844f9de..362544477a1275020e1b93578404bb4f5171b3c9 100644
--- a/html-test/ref/Bug1033.html
+++ b/html-test/ref/Bug1033.html
@@ -88,10 +88,8 @@
> <a href="#" class="selflink"
>#</a
></td
- ><td class="doc"
- ><p
- >This does some generic foos.</p
- ></td
+ ><td class="doc empty"
+ > </td
></tr
><tr
><td colspan="2"
@@ -166,8 +164,10 @@
> <a href="#" class="selflink"
>#</a
></td
- ><td class="doc empty"
- > </td
+ ><td class="doc"
+ ><p
+ >This does some generic foos.</p
+ ></td
></tr
><tr
><td colspan="2"
diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html
index b8b8ff0fb11235089454f146ce0502a4bf6747e4..da7ae1d2192627bae48f8ff98232bdfffc099804 100644
--- a/html-test/ref/Bug1050.html
+++ b/html-test/ref/Bug1050.html
@@ -95,7 +95,7 @@
>forall</span
> {k} {f :: <span class="keyword"
>forall</span
- > k1. k1 -> <a href="#" title="Data.Kind"
+ > k. k -> <a href="#" title="Data.Kind"
>Type</a
>} {a :: k}. f a -> <a href="#" title="Bug1050"
>T</a
diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html
index 3c7cf13f751350b216b803f2a95a50e5d37ee5e3..e2024f477b963f5a25d807cac01dfff6787a4c9b 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 2434a85723be70092e0f296ca1a22f82f36d41ac..8814129d9cfa982455153ee48533e05476f7da30 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 7389084559a09a34a7965d1a57822d5a084afd0a..4d6fe69bb1db6a1baedd9ff6bbe0a93e5645dc9e 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 fb6518aff08fd13341064b7e83852d6d6a5d9bac..f3a1010daaa1aaa68ae7adf0c4e49d57bf449835 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"
diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html
index b680fe6666a879c4701881da52d5899ced16cdd9..9ef3a85da5bd91043c737184336ea3ed20cf3894 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"
diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html
index 2eb2cda3923e7a640fae70b4882033b608cfdc49..e3c7b6e7deaae6d074a1786e2a997d971178a136 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 d828ea1d7ab902436cc1edc13fbad71968d4c279..1ea5109967499d823fca89e45a75f1758091f994 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 8ef49cedd3012c16ae879191b8873bfac09fb387..d44d57416ee5d6eb61270b523bbffb9a85406d6e 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 f59629a29a9a8be40b9d623c7e87f39b3a66ff22..1b47e6409a7035188f521ba3cdfed12e6187ec5c 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 3277c468ca4a33763e879a8c0c0aa494ee58164c..8391431ed7e577e903c9a47538365bf2869d7aec 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 9d04e8c59a1c9c1a31c2d3ea52e535c23acf0c5e..bd596be0bfaab061a6fc24d3c9186101c4b10b23 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"