diff --git a/cabal.project b/cabal.project index e89a2cd531..dd6e02b7f7 100644 --- a/cabal.project +++ b/cabal.project @@ -20,4 +20,4 @@ package haddock-api tests: False -- Pinning the index-state helps to make reasonably CI deterministic -index-state: 2022-08-05T20:43:48Z +index-state: 2022-11-05T20:43:48Z diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index bf237e5642..fcba7a7fe8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -49,6 +49,7 @@ library , haddock-library ^>= 1.11 , xhtml ^>= 3000.2.2 , parsec ^>= 3.1.13.0 + , text ^>= 2.0 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -58,10 +59,10 @@ library , containers , deepseq , directory - , exceptions + , exceptions , filepath , ghc-boot - , mtl + , mtl , transformers hs-source-dirs: src diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 23c8113f9b..46831ef327 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -51,7 +51,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) -import Data.List (find, isPrefixOf, nub) +import Data.List (find, isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef @@ -461,7 +461,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d ppJsonIndex odir sourceUrls' opt_wiki_urls unicode Nothing qual ifaces - ( nub + ( ordNub . map fst . filter ((== Visible) . piVisibility . snd) $ packages) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 08ef747aa1..ab3efa3a66 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,12 +17,12 @@ module Haddock.Backends.Xhtml.Themes ( where import Haddock.Options +import Haddock.Utils (ordNub) import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) -import Data.List (nub) import Data.Maybe (isJust, listToMaybe) import System.Directory @@ -174,7 +174,7 @@ isCssFilePath path = takeExtension path == ".css" -------------------------------------------------------------------------------- cssFiles :: Themes -> [String] -cssFiles ts = nub $ concatMap themeFiles ts +cssFiles ts = ordNub $ concatMap themeFiles ts styleSheet :: BaseURL -> Themes -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fd5300d245..4f42955318 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} +{-# LANGUAGE CPP, OverloadedStrings, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -313,7 +313,7 @@ synifyTyCon _prr coax tc , tcdFixity = synifyFixity name , tcdDataDefn = defn , tcdDExt = DataDeclRn False emptyNameSet } - dataConErrs -> Left $ unlines dataConErrs + dataConErrs -> Left $ errMsgUnlines dataConErrs -- | In this module, every TyCon being considered has come from an interface -- file. This means that when considering a data type constructor such as: diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 92b727acd2..0811ce0157 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -42,17 +42,19 @@ import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv, expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage, - ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE) + ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, throwE, runErrMsgM, errorMessagesToList) import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) -import Data.List (foldl', isPrefixOf, nub) +import Data.List (foldl', isPrefixOf) import Text.Printf (printf) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.ByteString.Builder import GHC hiding (verbosity) import GHC.Data.Graph.Directed import GHC.Driver.Env @@ -120,8 +122,8 @@ processModules verbosity modules flags extIfaces = do let warnings = Flag_NoWarnings `notElem` flags dflags <- getDynFlags let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' - liftIO $ mapM_ putStrLn msgs + runErrMsgM $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' + liftIO $ mapM_ (BSL.putStrLn . toLazyByteString) (errorMessagesToList msgs) return (interfaces'', homeLinks) @@ -324,7 +326,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env , unQualOK gre -- In scope unqualified ] - liftIO $ mapM_ putStrLn (nub messages) + liftIO $ mapM_ BSL.putStrLn (ordNub (map toLazyByteString messages)) dflags <- getDynFlags let diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 4527360fa1..e63ad5dfbe 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -124,7 +124,7 @@ attachToExportItem index expInfo getInstDoc getFixity export = cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do - let mkBug = (text "haddock-bug:" <+>) . text + let mkBug = (text "haddock-bug:" <+>) . text . errMsgToString putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e3c4a52952..f4c9dc68c2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} @@ -39,9 +40,12 @@ import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) +import Control.Monad (liftM) import Control.Applicative ((<|>)) import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) -import Control.Monad.Writer.Strict hiding (tell) +import Control.Monad.Trans (lift) +import Control.Monad.Writer (MonadWriter(..)) +import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT) import Data.Bitraversable (bitraverse) import Data.List (find, foldl') import qualified Data.IntMap as IM @@ -50,6 +54,8 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) import Data.Traversable (for) +import Data.Foldable (traverse_) +import Control.Monad.IO.Class import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) @@ -93,22 +99,22 @@ newtype IfEnv m = IfEnv -- 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 } - +newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT ErrorMessages m) a } deriving newtype instance Functor m => Functor (IfM m) -deriving newtype instance Applicative m => Applicative (IfM m) +deriving newtype instance Monad 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 Monad m => MonadWriter ErrorMessages (IfM m) +deriving newtype instance Monad m => ReportErrorMessage (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)) + :: Functor m + => (Name -> m (Maybe TyThing)) -- | The action to run. -> IfM m a -- | Result and accumulated error/warning messages. @@ -119,12 +125,12 @@ runIfM lookup_name action = do { ife_lookup_name = lookup_name } - runWriterT (runReaderT (unIfM action) if_env) + fmap errorMessagesToList <$> runWriterT (runReaderT (unIfM action) if_env) liftErrMsg :: Monad m => ErrMsgM a -> IfM m a liftErrMsg action = do - writer (runWriter action) + IfM (writer (runErrMsgM action)) lookupName :: Monad m => Name -> IfM m (Maybe TyThing) @@ -204,7 +210,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do decls <- case tcg_rn_decls of Nothing -> do - tell [ "Warning: Renamed source is not available" ] + reportErrorMessage "Warning: Renamed source is not available" pure [] Just dx -> pure (topDecls dx) @@ -441,7 +447,7 @@ mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] mkDocOpts mbOpts flags mdl = do opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of - [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] + [] -> reportErrorMessage "No option supplied to DOC_OPTION/doc_option" >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] pure (foldl go opts flags) @@ -462,7 +468,7 @@ parseOption "prune" = return (Just OptPrune) parseOption "ignore-exports" = return (Just OptIgnoreExports) parseOption "not-home" = return (Just OptNotHome) parseOption "show-extensions" = return (Just OptShowExtensions) -parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing +parseOption other = reportErrorMessage ("Unrecognised option: " <> errMsgFromString other) >> return Nothing -------------------------------------------------------------------------------- @@ -733,12 +739,12 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- parents is also exported. See note [1]. | t `notElem` declNames, Just p <- find isExported (parents t $ unL decl) -> - do liftErrMsg $ tell [ - "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty dflags (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty dflags (nameOccName p) ++ - ". Consider exporting it together with its parent(s)" ++ - " for code clarity." ] + do reportErrorMessage $ + "Warning: " <> errMsgFromString (moduleString thisMod) <> ": " <> + errMsgFromString (pretty dflags (nameOccName t)) <> " is exported separately but " <> + "will be documented under " <> errMsgFromString (pretty dflags (nameOccName p)) <> + ". Consider exporting it together with its parent(s)" <> + " for code clarity." return [] -- normal case @@ -772,8 +778,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- with signature inheritance case M.lookup (nameModule t) instIfaceMap of Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] + reportErrorMessage + $ "Warning: Couldn't find .haddock for export " <> errMsgFromString (pretty dflags t) let subs_ = availNoDocs avail availExportDecl avail decl (noDocForDecl, subs_) Just iface -> @@ -790,7 +796,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames synifiedDeclOpt <- hiDecl dflags declName case synifiedDeclOpt of Just synifiedDecl -> pure synifiedDecl - Nothing -> pprPanic "availExportItem" (O.text err) + Nothing -> pprPanic "availExportItem" (O.text (show err)) availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) @@ -907,17 +913,20 @@ hiDecl dflags t = do mayTyThing <- lookupName t case mayTyThing of Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] + reportErrorMessage ("Warning: Not found in environment: " <> errMsgFromString (pretty dflags t)) return Nothing Just x -> case tyThingToLHsDecl ShowRuntimeRep x of - Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing - Right (m, t') -> liftErrMsg (tell $ map bugWarn m) - >> return (Just $ noLocA t') + Left m -> do + reportErrorMessage (bugWarn m) + return Nothing + Right (m, t') -> do + traverse_ (reportErrorMessage . bugWarn) m + return (Just $ noLocA t') where - warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> + warnLine x = O.text "haddock-bug:" O.<+> O.text (errMsgToString x) O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> O.text "-- Please report this on Haddock issue tracker!" - bugWarn = showSDoc dflags . warnLine + bugWarn = errMsgFromString . showSDoc dflags . warnLine -- | This function is called for top-level bindings without type signatures. -- It gets the type signature from GHC and that means it's not going to @@ -976,8 +985,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] + reportErrorMessage ( "Warning: " <> fromString (pretty dflags thisMod) <> ": Could not find " <> + "documentation for exported module: " <> fromString (pretty dflags expMod) ) return [] where m = mkModule (moduleUnit thisMod) expMod -- Identity module! @@ -1093,8 +1102,8 @@ extractDecl declMap name decl ([], []) | Just (famInstDecl:_) <- M.lookup name declMap -> extractDecl declMap name famInstDecl - _ -> Left (concat [ "Ambiguous decl for ", getOccString name - , " in class ", getOccString clsNm ]) + _ -> Left (mconcat [ "Ambiguous decl for ", errMsgFromString (getOccString name) + , " in class ", errMsgFromString (getOccString clsNm) ]) TyClD _ d@DataDecl { tcdLName = L _ dataNm , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do @@ -1135,14 +1144,14 @@ extractDecl declMap name decl in case matches of [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) _ -> Left "internal: extractDecl (ClsInstD)" - _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) + _ -> Left ("extractDecl: Unhandled decl for " <> fromString (getOccString name)) extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> Left . O.showSDocOneLine O.defaultSDocContext $ + [] -> Left . errMsgFromString . O.showSDocOneLine O.defaultSDocContext $ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where @@ -1233,7 +1242,7 @@ findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do - tell ["Cannot find documentation for: $" ++ name] + reportErrorMessage ("Cannot find documentation for: $" <> errMsgFromString name) return Nothing search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just (hsDocString . unLoc $ doc)) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 455f331405..2fc64d49b6 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 OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- @@ -39,6 +40,7 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet +import Data.Foldable (traverse_) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -195,8 +197,8 @@ outOfScope dflags ns x = warnAndMonospace a = do let a' = showWrapped (showPpr dflags) a - tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it anyway."] + reportErrorMessage $ "Warning: " <> prefix <> "'" <> fromString a' <> "' is out of scope.\n" <> + " If you qualify the identifier, haddock can try to link it anyway." pure (monospaced a') monospaced = DocMonospaced . DocString @@ -212,17 +214,21 @@ ambiguous :: DynFlags ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ - " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by specifying the type/value namespace explicitly.\n" ++ - " Defaulting to the one defined " ++ defnLoc dflt + msgs :: [ErrMsg] + msgs = + [ "Warning: " <> fromString (showNsRdrName dflags x) <> " is ambiguous. It is defined" + ] <> + map (\n -> " * " <> fromString (defnLoc n)) (map greMangledName gres) <> + [ " You may be able to disambiguate the identifier by qualifying it or" + , " by specifying the type/value namespace explicitly." + , " Defaulting to the one defined " <> fromString (defnLoc dflt) + ] -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. - when (length noChildren > 1) $ tell [msg] + when (length noChildren > 1) $ traverse_ reportErrorMessage msgs pure (DocIdentifier (x $> dflt)) where isLocalName (nameSrcLoc -> RealSrcLoc {}) = True @@ -234,9 +240,9 @@ ambiguous dflags x gres = do -- Emits a warning that the value-namespace is invalid on a non-value identifier. invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) invalidValue dflags x = do - tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ - " namespaced as such. Did you mean to specify a type namespace\n" ++ - " instead?"] + reportErrorMessage $ "Warning: " <> fromString (showNsRdrName dflags x) <> " cannot be value, yet it is" + reportErrorMessage $ " namespaced as such. Did you mean to specify a type namespace" + reportErrorMessage $ " instead?" pure (DocMonospaced (DocString (showNsRdrName dflags x))) -- | Printable representation of a wrapped and namespaced name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 6057bf75c8..3ecac88ce6 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ---------------------------------------------------------------------------- -- | @@ -26,6 +27,7 @@ import GHC.Types.Name import GHC.Types.Name.Reader (RdrName(Exact)) import GHC.Builtin.Types (eqTyCon_RDR) +import Data.Foldable (traverse_) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) @@ -85,7 +87,7 @@ renameInterface _dflags ignoredSymbols renamingEnv warnings iface = ignoreSet = Set.fromList ignoredSymbols - strings = [ qualifiedName n + strings = [ errMsgFromString (qualifiedName n) | n <- missingNames , not (qualifiedName n `Set.member` ignoreSet) @@ -97,10 +99,10 @@ renameInterface _dflags ignoredSymbols renamingEnv warnings iface = in do -- report things that we couldn't link to. Only do this for non-hidden -- modules. - unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod iface) ++ - ": could not find link destinations for:\n"++ - intercalate "\n\t- " ("" : strings) ] + unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ do + reportErrorMessage $ "Warning: " <> fromString (moduleString (ifaceMod iface)) <> + ": could not find link destinations for: " + traverse_ (reportErrorMessage . mappend "\t- ") strings return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6c98c830ba..d1d5c73bd7 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -34,13 +34,20 @@ module Haddock.Types ( -- $ Reexports , runWriter , tell + , fromString ) where +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.String import Control.DeepSeq import Control.Exception (throw) import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) +import qualified Control.Monad.Trans.Writer.CPS as CPS +import Control.Monad.Trans.Writer.CPS (Writer, WriterT, runWriter, runWriterT) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Reader (ReaderT(..)) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) @@ -49,12 +56,16 @@ import Documentation.Haddock.Types import GHC.Types.Basic (PromotionFlag(..)) import GHC.Types.Fixity (Fixity(..)) import GHC.Types.Var (Specificity) +import Data.ByteString.Builder +import qualified Data.List as List +import Control.Monad.Trans (lift) +import qualified Data.ByteString.Lazy as BSL import GHC import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Name.Occurrence -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -640,9 +651,49 @@ data SinceQual -- A monad which collects error messages, locally defined to avoid a dep on mtl -type ErrMsg = String -type ErrMsgM = Writer [ErrMsg] +type ErrMsg = Builder +errMsgFromString :: String -> ErrMsg +errMsgFromString = fromString + +errMsgToString :: ErrMsg -> String +errMsgToString = Text.unpack . Text.decodeUtf8 . BSL.toStrict . toLazyByteString + +errMsgUnlines :: [ErrMsg] -> ErrMsg +errMsgUnlines = mconcat . List.intersperse (charUtf8 '\n') + +class Monad m => ReportErrorMessage m where + reportErrorMessage :: Builder -> m () + +instance ReportErrorMessage m => ReportErrorMessage (ReaderT r m) where + reportErrorMessage = lift . reportErrorMessage + +#if !MIN_VERSION_mtl(2,3,0) +-- | @since 2.3 +instance (Monoid w, Monad m) => MonadWriter w (CPS.WriterT w m) where + writer = CPS.writer + tell = CPS.tell + listen = CPS.listen + pass = CPS.pass +#endif + +instance Monad m => ReportErrorMessage (WriterT ErrorMessages m) where + reportErrorMessage = tell . singleMessage + +newtype ErrMsgM a = ErrMsgM { unErrMsgM :: Writer ErrorMessages a } + deriving newtype (Functor, Applicative, Monad, ReportErrorMessage) + +newtype ErrorMessages = ErrorMessages { unErrorMessages :: [Builder] -> [Builder] } + deriving newtype (Semigroup, Monoid) + +runErrMsgM :: ErrMsgM a -> (a, ErrorMessages) +runErrMsgM = runWriter . unErrMsgM + +singleMessage :: Builder -> ErrorMessages +singleMessage m = ErrorMessages $ (m :) + +errorMessagesToList :: ErrorMessages -> [Builder] +errorMessagesToList messages = unErrorMessages messages [] -- Exceptions @@ -675,24 +726,24 @@ 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 = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } +newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT ErrorMessages Ghc a } deriving newtype instance Functor ErrMsgGhc deriving newtype instance Applicative ErrMsgGhc deriving newtype instance Monad ErrMsgGhc -deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc +deriving newtype instance ReportErrorMessage ErrMsgGhc deriving newtype instance MonadIO ErrMsgGhc -runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg]) +runWriterGhc :: ErrMsgGhc a -> Ghc (a, ErrorMessages) runWriterGhc = runWriterT . unErrMsgGhc liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a liftGhcToErrMsgGhc = ErrMsgGhc . lift liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = writer . runWriter +liftErrMsg = ErrMsgGhc . writer . runErrMsgM ----------------------------------------------------------------------------- -- * Pass sensitive types diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 314b8db9e6..0f2b8b9e6c 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -41,6 +41,7 @@ module Haddock.Utils ( -- * List utilities replace, spanWith, + ordNub, -- * Logging parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, @@ -51,6 +52,7 @@ module Haddock.Utils ( ) where +import qualified Data.Set as Set import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types @@ -116,7 +118,8 @@ out progVerbosity msgVerbosity msg -- * Some Utilities -------------------------------------------------------------------------------- - +ordNub :: Ord a => [a] -> [a] +ordNub = Set.toList . Set.fromList mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } diff --git a/haddock.cabal b/haddock.cabal index 64ec969965..924b712ec6 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -150,7 +150,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.27.0 + build-depends: haddock-api == 2.27.1 test-suite html-test type: exitcode-stdio-1.0