aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorAlex Biehl <alex@groundcloud.com>2021-01-07 23:40:56 +0100
committerAlexander Biehl <alexbiehl@gmail.com>2021-01-09 12:14:41 +0100
commit703e5f0263dfc7c3173cf8ae1348c14902b9bcd7 (patch)
treec632bc16903452752562b0e0bc276a261f2c4b03 /haddock-api/src/Haddock
parente81e024703ed8bba3c45a679e08003ccba68e046 (diff)
Abstract Monad for interface creation
I found that when running as a plugin the lookupName function (which runs in Ghc monad) does not work correctly from the typeCheckResultAction hook. Instead, we abstracted the monad used when creating interfaces, so that access to GHC session specific parts is explicit and so that the TcM can provide their (correct) implementation of lookupName.
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs9
-rw-r--r--haddock-api/src/Haddock/Interface.hs32
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs335
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs1
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs2
-rw-r--r--haddock-api/src/Haddock/Options.hs3
-rw-r--r--haddock-api/src/Haddock/Types.hs67
9 files changed, 179 insertions, 275 deletions
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 452cb6f4..0a0211c9 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
@@ -403,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 87ac4861..c557968f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -61,8 +61,9 @@ import GHC hiding (verbosity)
import GHC.Driver.Env
import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
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 (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, greMangledName, globalRdrEnvElts)
@@ -202,15 +203,16 @@ 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 =
pure ()
| otherwise = do
+ hsc_env <- getTopEnv
ifaces <- liftIO $ readIORef ifaceMapRef
(iface, modules) <- withTimingD "processModule" (const ()) $
- processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env
+ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
liftIO $ do
atomicModifyIORef' ifaceMapRef $ \xs ->
@@ -227,11 +229,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
}
@@ -246,33 +245,32 @@ plugin verbosity flags instIfaceMap = liftIO $ do
)
-
processModule1
:: Verbosity
-> [Flag]
-> IfaceMap
-> InstIfaceMap
+ -> HscEnv
-> ModSummary
-> TcGblEnv
- -> Ghc (Interface, ModuleSet)
-processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
+ -> 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 <$> getSession
+ unit_state = hsc_units hsc_env
(!interface, messages) <- {-# SCC createInterface #-}
- withTimingD "createInterface" (const ()) $
- runWriterGhc $ createInterface1 flags unit_state
- mod_summary tc_gbl_env ifaces inst_ifaces
+ 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.
- hsc_env <- getSession
let
mods :: ModuleSet
!mods = mkModuleSet
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 8bf9d7d6..30fb8b7e 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,43 +20,42 @@
-- 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 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
@@ -65,14 +66,68 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import GHC.Unit.Module.Warnings
+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
- :: [Flag]
+ :: MonadIO m
+ => [Flag]
-> UnitState
-> ModSummary
-> TcGblEnv
-> IfaceMap
-> InstIfaceMap
- -> ErrMsgGhc Interface
+ -> IfM m Interface
createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
let
@@ -134,7 +189,7 @@ createInterface1 flags unit_state 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)
@@ -250,142 +305,6 @@ createInterface1 flags unit_state 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 :: 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
-
- -- 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 imports
-
- 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
- }
-
-
-- | 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
@@ -640,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
@@ -657,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
@@ -699,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
@@ -753,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_
@@ -783,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
@@ -828,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
@@ -857,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)
@@ -890,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]
@@ -911,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
@@ -942,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.
@@ -961,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!
@@ -989,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 44c02875..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)
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 65aacc61..04189b99 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -46,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
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53a91cf5..32f14f74 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