aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Utils.hs
diff options
context:
space:
mode:
authoralexbiehl-gc <72160047+alexbiehl-gc@users.noreply.github.com>2021-02-07 18:14:46 +0100
committerGitHub <noreply@github.com>2021-02-07 18:14:46 +0100
commit0f7ff041fb824653a7930e1292b81f34df1e967d (patch)
tree3e7f15ac3b0abe417797ec89275aa1209f6ca297 /haddock-api/src/Haddock/Utils.hs
parent9f597b6647a53624eaf501a34bfb4d8d15425929 (diff)
parent010f0320dff64e3f86091ba4691bc69ce6999647 (diff)
Merge pull request #1317 from bgamari/wip/ghc-head-merge
Merge ghc-8.10 into ghc-head
Diffstat (limited to 'haddock-api/src/Haddock/Utils.hs')
-rw-r--r--haddock-api/src/Haddock/Utils.hs212
1 files changed, 27 insertions, 185 deletions
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 8a6b6349..314b8db9 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -16,16 +16,9 @@
-----------------------------------------------------------------------------
module Haddock.Utils (
- -- * Misc utilities
- restrictTo, emptyHsQTvs,
- toDescription, toInstalledDescription,
- mkEmptySigWcType, mkEmptySigType,
- addClassContext, lHsQTyVarsToTypes,
-
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
contentsHtmlFile, indexHtmlFile, indexJsonFile,
- moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
haddockJsFile, jsQuickJumpFile,
quickJumpCssFile,
@@ -36,7 +29,7 @@ module Haddock.Utils (
makeAnchorId,
-- * Miscellaneous utilities
- getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ getProgramName, bye, die, escapeStr,
writeUtf8File, withTempDir,
-- * HTML cross reference mapping
@@ -49,11 +42,8 @@ module Haddock.Utils (
replace,
spanWith,
- -- * MTL stuff
- MonadIO(..),
-
-- * Logging
- parseVerbosity,
+ parseVerbosity, Verbosity(..), silent, normal, verbose, deafening,
out,
-- * System tools
@@ -63,46 +53,54 @@ module Haddock.Utils (
import Documentation.Haddock.Doc (emptyMetaDoc)
import Haddock.Types
-import Haddock.GhcUtils
-import GHC.Types.Basic ( PromotionFlag(..) )
-import GHC.Utils.Exception (ExceptionMonad)
import GHC
import GHC.Types.Name
-import Control.Monad ( liftM )
-import Control.Monad.Catch ( bracket_ )
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Control.Monad.Catch ( MonadMask, bracket_ )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
import Numeric ( showIntAtBase )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
-import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit
import System.Directory ( createDirectory, removeDirectoryRecursive )
-import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
+import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
-import Distribution.Verbosity
-import Distribution.ReadE
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
#endif
-import GHC.Utils.Monad ( MonadIO(..) )
-
-
--------------------------------------------------------------------------------
-- * Logging
--------------------------------------------------------------------------------
+data Verbosity = Silent | Normal | Verbose | Deafening
+ deriving (Eq, Ord, Enum, Bounded, Show)
-parseVerbosity :: String -> Either String Verbosity
-parseVerbosity = runReadE flagToVerbosity
+silent, normal, verbose, deafening :: Verbosity
+silent = Silent
+normal = Normal
+verbose = Verbose
+deafening = Deafening
+-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing.
+parseVerbosity :: String -> Either String Verbosity
+parseVerbosity "0" = Right Silent
+parseVerbosity "1" = Right Normal
+parseVerbosity "2" = Right Silent
+parseVerbosity "3" = Right Deafening
+parseVerbosity "silent" = return Silent
+parseVerbosity "normal" = return Normal
+parseVerbosity "verbose" = return Verbose
+parseVerbosity "debug" = return Deafening
+parseVerbosity "deafening" = return Deafening
+parseVerbosity other = Left ("Can't parse verbosity " ++ other)
-- | Print a message to stdout, if it is not too verbose
out :: MonadIO m
@@ -119,144 +117,14 @@ out progVerbosity msgVerbosity msg
--------------------------------------------------------------------------------
--- | Extract a module's short description.
-toDescription :: Interface -> Maybe (MDoc Name)
-toDescription = fmap mkMeta . hmi_description . ifaceInfo
-
-
--- | Extract a module's short description.
-toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
-toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
-mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptySigType ty)
-
-mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigType lty@(L loc ty) = L loc $ case ty of
- HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
- , hst_body = body }
- -> HsSig { sig_ext = noExtField
- , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField
- , hso_bndrs = bndrs }
- , sig_body = body }
- _ -> HsSig { sig_ext = noExtField
- , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}
- , sig_body = lty }
-
-addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
--- Add the class context to a class-op signature
-addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
- where
- go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
- = L loc (HsSig { sig_ext = noExtField
- , sig_bndrs = bndrs, sig_body = go_ty ty })
-
- go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
- = L loc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = tele, hst_body = go_ty ty })
- go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt ctxt, hst_body = ty })
- go_ty (L loc ty)
- = L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
-
- extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt (L loc preds) = L loc (extra_pred : preds)
-
-addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-
-lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
-lHsQTyVarsToTypes tvs
- = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
- | tv <- hsQTvExplicit tvs ]
-
---------------------------------------------------------------------------------
--- * Making abstract declarations
---------------------------------------------------------------------------------
-
-
-restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
-restrictTo names (L loc decl) = L loc $ case decl of
- TyClD x d | isDataDecl d ->
- TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD x d | isClassDecl d ->
- TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
- tcdATs = restrictATs names (tcdATs d) })
- _ -> decl
-
-restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
- | DataType <- new_or_data
- = defn { dd_cons = restrictCons names cons }
- | otherwise -- Newtype
- = case restrictCons names cons of
- [] -> defn { dd_ND = DataType, dd_cons = [] }
- [con] -> defn { dd_cons = [con] }
- _ -> error "Should not happen"
-
-restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
- where
- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
- case d of
- ConDeclH98 { con_args = args } -> restrict_h98_args args
- ConDeclGADT { con_g_args = args } -> restrict_gadt_args args
- where
- restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn)
- restrict_h98_args (PrefixCon _ _) = Just d
- restrict_h98_args (RecCon (L _ fields))
- | all field_avail fields = Just d
- | otherwise = Just (d { con_args = PrefixCon noTypeArgs (field_types fields) })
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
-
- restrict_h98_args (InfixCon _ _) = Just d
-
- restrict_gadt_args :: HsConDeclGADTDetails GhcRn -> Maybe (ConDecl GhcRn)
- restrict_gadt_args (PrefixConGADT _) = Just d
- restrict_gadt_args (RecConGADT (L _ fields))
- | all field_avail fields = Just d
- | otherwise = Just (d { con_g_args = PrefixConGADT (field_types fields) })
- -- see the comments for the RecCon case of `restrict_h98_args` above
-
- field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField _ fs _ _))
- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
- field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
-
- keep _ = Nothing
-
-restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-
-
-restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-
-emptyHsQTvs :: LHsQTyVars GhcRn
--- This function is here, rather than in HsTypes, because it *renamed*, but
--- does not necessarily have all the rigt kind variables. It is used
--- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs"
- , hsq_explicit = [] }
-
-
--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
--------------------------------------------------------------------------------
-
baseName :: ModuleName -> FilePath
baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
@@ -283,13 +151,6 @@ indexHtmlFile = "doc-index.html"
indexJsonFile = "doc-index.json"
-
-moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
-moduleIndexFrameName = "modules"
-mainFrameName = "main"
-synopsisFrameName = "synopsis"
-
-
subIndexHtmlFile :: String -> String
subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
where b | all isAlpha ls = ls
@@ -363,7 +224,7 @@ quickJumpCssFile = "quick-jump.css"
getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+getProgramName = fmap (`withoutSuffix` ".bin") getProgName
where str `withoutSuffix` suff
| suff `isSuffixOf` str = take (length str - length suff) str
| otherwise = str
@@ -372,25 +233,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
bye :: String -> IO a
bye s = putStr s >> exitSuccess
-
-dieMsg :: String -> IO ()
-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
-
-
-noDieMsg :: String -> IO ()
-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
-
-
-mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
-mapSnd _ [] = []
-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
-
-
-mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM _ Nothing = return Nothing
-mapMaybeM f (Just a) = liftM Just (f a)
-
-
escapeStr :: String -> String
escapeStr = escapeURIString isUnreserved
@@ -437,9 +279,9 @@ writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
hSetEncoding h utf8
hPutStr h contents
-withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
+withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
withTempDir dir = bracket_ (liftIO $ createDirectory dir)
- (liftIO $ removeDirectoryRecursive dir)
+ (liftIO $ removeDirectoryRecursive dir)
-----------------------------------------------------------------------------
-- * HTML cross references