Merge pull request #1317 from bgamari/wip/ghc-head-merge

Merge ghc-8.10 into ghc-head

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