compiler/GHC/Cmm/GenericOpt.hs

@@ -5,6 +5,7 @@
 --
 -- -----------------------------------------------------------------------------
 
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UnboxedTuples #-}
 
@@ -26,7 +27,8 @@ import GHC.Cmm.Opt           ( cmmMachOpFold )
 import GHC.Cmm.CLabel
 import GHC.Data.FastString
 import GHC.Unit
-import Control.Monad
+import Control.Monad.Trans.Reader
+import GHC.Utils.Monad.State.Strict as Strict
 
 -- -----------------------------------------------------------------------------
 -- Generic Cmm optimiser
@@ -67,19 +69,7 @@ pattern OptMResult x y = (# x, y #)
 {-# COMPLETE OptMResult #-}
 
 newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
-    deriving (Functor)
-
-instance Applicative CmmOptM where
-    pure x = CmmOptM $ \_ imports -> OptMResult x imports
-    (<*>) = ap
-
-instance Monad CmmOptM where
-  (CmmOptM f) >>= g =
-    CmmOptM $ \config imports0 ->
-                case f config imports0 of
-                  OptMResult x imports1 ->
-                    case g x of
-                      CmmOptM g' -> g' config imports1
+    deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))
 
 instance CmmMakeDynamicReferenceM CmmOptM where
     addImport = addImportCmmOpt

compiler/GHC/CmmToAsm/Reg/Linear/State.hs

-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UnboxedTuples #-}
 
@@ -52,31 +52,24 @@ import GHC.Types.Unique
 import GHC.Types.Unique.Supply
 import GHC.Exts (oneShot)
 
-import Control.Monad (ap)
+import GHC.Utils.Monad.State.Strict as Strict
 
-type RA_Result freeRegs a = (# RA_State freeRegs, a #)
+type RA_Result freeRegs a = (# a, RA_State freeRegs #)
 
-pattern RA_Result :: a -> b -> (# a, b #)
-pattern RA_Result a b = (# a, b #)
+pattern RA_Result :: a -> b -> (# b, a #)
+pattern RA_Result a b = (# b, a #)
 {-# COMPLETE RA_Result #-}
 
 -- | The register allocator monad type.
 newtype RegM freeRegs a
         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
-        deriving (Functor)
+        deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))
 
 -- | Smart constructor for 'RegM', as described in Note [The one-shot state
 -- monad trick] in GHC.Utils.Monad.
 mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
 mkRegM f = RegM (oneShot f)
 
-instance Applicative (RegM freeRegs) where
-      pure a  =  mkRegM $ \s -> RA_Result s a
-      (<*>) = ap
-
-instance Monad (RegM freeRegs) where
-  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
-
 -- | Get native code generator configuration
 getConfig :: RegM a NCGConfig
 getConfig = mkRegM $ \s -> RA_Result s (ra_config s)

compiler/GHC/Driver/Errors.hs

@@ -13,7 +13,7 @@ import GHC.Utils.Error
 import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext )
 import GHC.Utils.Logger
 
-printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
+printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
 printMessages logger msg_opts opts msgs
   = sequence_ [ let style = mkErrStyle name_ppr_ctx
                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
@@ -28,7 +28,7 @@ printMessages logger msg_opts opts msgs
                                   errMsgContext    = name_ppr_ctx }
                   <- sortMsgBag (Just opts) (getMessages msgs) ]
   where
-    messageWithHints :: Diagnostic a => a -> SDoc
+    messageWithHints :: a -> SDoc
     messageWithHints e =
       let main_msg = formatBulleted $ diagnosticMessage msg_opts e
           in case diagnosticHints e of

compiler/GHC/Driver/Errors/Ppr.hs

@@ -62,7 +62,7 @@ instance Diagnostic GhcMessage where
       -> diagnosticMessage (dsMessageOpts opts) m
     GhcDriverMessage m
       -> diagnosticMessage (driverMessageOpts opts) m
-    GhcUnknownMessage (UnknownDiagnostic f m)
+    GhcUnknownMessage (UnknownDiagnostic f _ m)
       -> diagnosticMessage (f opts) m
 
   diagnosticReason = \case
@@ -97,7 +97,7 @@ instance HasDefaultDiagnosticOpts DriverMessageOpts where
 instance Diagnostic DriverMessage where
   type DiagnosticOpts DriverMessage = DriverMessageOpts
   diagnosticMessage opts = \case
-    DriverUnknownMessage (UnknownDiagnostic f m)
+    DriverUnknownMessage (UnknownDiagnostic f _ m)
       -> diagnosticMessage (f opts) m
     DriverPsHeaderMessage m
       -> diagnosticMessage (psDiagnosticOpts opts) m

compiler/GHC/Driver/Errors/Types.hs

@@ -94,7 +94,7 @@ data GhcMessage where
   -- 'Diagnostic' constraint ensures that worst case scenario we can still
   -- render this into something which can be eventually converted into a
   -- 'DecoratedSDoc'.
-  GhcUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts GhcMessage)) -> GhcMessage
+  GhcUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts GhcMessage) GhcHint) -> GhcMessage
 
   deriving Generic
 
@@ -111,7 +111,7 @@ data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage
 -- conversion can happen gradually. This function should not be needed within
 -- GHC, as it would typically be used by plugin or library authors (see
 -- comment for the 'GhcUnknownMessage' type constructor)
-ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage
+ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint, Diagnostic a, Typeable a) => a -> GhcMessage
 ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic
 
 -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
@@ -130,7 +130,7 @@ type DriverMessages = Messages DriverMessage
 -- | A message from the driver.
 data DriverMessage where
   -- | Simply wraps a generic 'Diagnostic' message @a@.
-  DriverUnknownMessage :: UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage
+  DriverUnknownMessage :: UnknownDiagnostic (DiagnosticOpts DriverMessage) GhcHint -> DriverMessage
 
   -- | A parse error in parsing a Haskell file header during dependency
   -- analysis

compiler/GHC/Driver/Make.hs

@@ -329,10 +329,12 @@ warnMissingHomeModules dflags targets mod_graph =
     -- Note also that we can't always infer the associated module name
     -- directly from the filename argument.  See #13727.
     is_known_module mod =
-      (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))
+      is_module_target mod
       ||
       maybe False is_file_target (ml_hs_file (ms_location mod))
 
+    is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets
+
     is_file_target file = Set.member (withoutExt file) file_targets
 
     file_targets = Set.fromList (mapMaybe file_target targets)
@@ -343,7 +345,7 @@ warnMissingHomeModules dflags targets mod_graph =
         TargetFile file _ ->
           Just (withoutExt (augmentByWorkingDirectory dflags file))
 
-    mod_targets = Map.fromList (mod_target <$> targets)
+    mod_targets = Set.fromList (mod_target <$> targets)
 
     mod_target Target {targetUnitId, targetId} =
       case targetId of
@@ -484,7 +486,7 @@ mkBatchMsg hsc_env =
     then batchMultiMsg
     else batchMsg
 
-type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage)
+type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage) GhcHint
 
 loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them.
                             -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.

compiler/GHC/Driver/Ppr.hs

@@ -6,6 +6,7 @@ module GHC.Driver.Ppr
    , showPpr
    , showPprUnsafe
    , printForUser
+   , printForUserColoured
    )
 where
 
@@ -34,6 +35,13 @@ showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDoc
       doc' = pprWithUnitState unit_state doc
 
 printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
-printForUser dflags handle name_ppr_ctx depth doc
+printForUser = printForUser' False
+
+printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
+printForUserColoured = printForUser' True
+
+printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
+printForUser' colour dflags handle name_ppr_ctx depth doc
   = printSDocLn ctx (PageMode False) handle doc
-    where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth)
+    where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth)
+

compiler/GHC/HsToCore/Errors/Ppr.hs

@@ -27,7 +27,7 @@ import GHC.HsToCore.Pmc.Ppr
 instance Diagnostic DsMessage where
   type DiagnosticOpts DsMessage = NoDiagnosticOpts
   diagnosticMessage opts = \case
-    DsUnknownMessage (UnknownDiagnostic f m)
+    DsUnknownMessage (UnknownDiagnostic f _ m)
       -> diagnosticMessage (f opts) m
     DsEmptyEnumeration
       -> mkSimpleDecorated $ text "Enumeration is empty"

compiler/GHC/HsToCore/Errors/Types.hs

@@ -31,7 +31,7 @@ type MaxPmCheckModels = Int
 -- | Diagnostics messages emitted during desugaring.
 data DsMessage
   -- | Simply wraps a generic 'Diagnostic' message.
-  = DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DsMessage))
+  = DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DsMessage) GhcHint)
 
     {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is
         emitted if an enumeration is empty.

compiler/GHC/HsToCore/Monad.hs

@@ -356,16 +356,16 @@ initTcDsForSolver thing_inside
   = do { (gbl, lcl) <- getEnvs
        ; hsc_env    <- getTopEnv
 
+         -- The DsGblEnv is used to inform the typechecker's solver of a few
+         -- key pieces of information:
+         --
+         --  - ds_fam_inst_env tells it how to reduce type families,
+         --  - ds_gbl_rdr_env  tells it which newtypes it can unwrap.
        ; let DsGblEnv { ds_mod = mod
                       , ds_fam_inst_env = fam_inst_env
-                      , ds_gbl_rdr_env  = rdr_env }      = gbl
-       -- This is *the* use of ds_gbl_rdr_env:
-       -- Make sure the solver (used by the pattern-match overlap checker) has
-       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
-       -- knows how to reduce type families, and which newtypes it can unwrap.
-
-
-             DsLclEnv { dsl_loc = loc }                  = lcl
+                      , ds_gbl_rdr_env  = rdr_env
+                      } = gbl
+             DsLclEnv { dsl_loc = loc } = lcl
 
        ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
          updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env

compiler/GHC/HsToCore/Pmc/Solver.hs

@@ -36,6 +36,7 @@ import GHC.Prelude
 
 import GHC.HsToCore.Pmc.Types
 import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)
+import GHC.HsToCore.Types (DsGblEnv(..))
 
 import GHC.Driver.DynFlags
 import GHC.Driver.Config
@@ -51,11 +52,14 @@ import GHC.Types.Unique.DSet
 import GHC.Types.Unique.SDFM
 import GHC.Types.Id
 import GHC.Types.Name
-import GHC.Types.Var      (EvVar)
+import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv)
+import GHC.Types.Var         (EvVar)
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Types.Unique.Supply
 
+import GHC.Tc.Utils.Monad   (getGblEnv)
+
 import GHC.Core
 import GHC.Core.FVs         (exprFreeVars)
 import GHC.Core.TyCo.Compare( eqType )
@@ -97,6 +101,7 @@ import Data.List     (sortBy, find)
 import qualified Data.List.NonEmpty as NE
 import Data.Ord      (comparing)
 
+
 --
 -- * Main exports
 --
@@ -1959,13 +1964,16 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
               -- No COMPLETE sets ==> inhabited
               generateInhabitingPatterns mode xs n newty_nabla
             Just clss -> do
-              -- Try each COMPLETE set, pick the one with the smallest number of
-              -- inhabitants
+              -- Try each COMPLETE set.
               nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)
-              let nablas' = minimumBy (comparing length) nablass'
-              if null nablas' && vi_bot vi /= IsNotBot
-                then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
-                else pure nablas'
+              if any null nablass' && vi_bot vi /= IsNotBot
+              then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
+              else do
+                -- Pick the residual COMPLETE set with the smallest cost (see 'completeSetCost').
+                -- See Note [Prefer in-scope COMPLETE matches].
+                DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv
+                let bestSet = map snd $ minimumBy (comparing $ completeSetCost rdr_env) nablass'
+                pure bestSet
 
     -- Instantiates a chain of newtypes, beginning at @x@.
     -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact
@@ -1979,13 +1987,13 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
       nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]
       instantiate_newtype_chain y nabla' dcs
 
-    instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]
+    instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)]
     instantiate_cons _ _  _  _ _     []       = pure []
     instantiate_cons _ _  _  0 _     _        = pure []
     instantiate_cons _ ty xs n nabla _
       -- We don't want to expose users to GHC-specific constructors for Int etc.
       | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True
-      = generateInhabitingPatterns mode xs n nabla
+      = map (Nothing,) <$> generateInhabitingPatterns mode xs n nabla
     instantiate_cons x ty xs n nabla (cl:cls) = do
       -- The following line is where we call out to the inhabitationTest!
       mb_nabla <- runMaybeT $ instCon 4 nabla x cl
@@ -2002,7 +2010,54 @@ generateInhabitingPatterns mode (x:xs) n nabla = do
         -- inhabited, otherwise the inhabitation test would have refuted.
         Just nabla' -> generateInhabitingPatterns mode xs n nabla'
       other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
-      pure (con_nablas ++ other_cons_nablas)
+      pure (map (Just cl,) con_nablas ++ other_cons_nablas)
+
+-- | If multiple residual COMPLETE sets apply, pick one as follows:
+--
+--  - prefer COMPLETE sets in which all constructors are in scope,
+--    as per Note [Prefer in-scope COMPLETE matches],
+--  - if there are ties, pick the one with the fewest (residual) ConLikes,
+--  - if there are ties, pick the one with the fewest "trivially inhabited" types,
+--  - if there are ties, pick the one with the fewest PatSyns,
+--  - if there are still ties, pick the one that comes first in the list of
+--    COMPLETE pragmas, which means the one that was brought into scope first.
+completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
+completeSetCost _ [] = (False, 0, 0, 0)
+completeSetCost rdr_env ((mb_con, _) : cons) =
+  let con_out_of_scope
+        | Just con <- mb_con
+        = isNothing $ lookupGRE_Name rdr_env (conLikeName con)
+        | otherwise
+        = False
+      (any_out_of_scope, nb_cons, nb_triv, nb_ps) = completeSetCost rdr_env cons
+  in ( any_out_of_scope || con_out_of_scope
+     , nb_cons + 1
+     , nb_triv + case mb_con of { Nothing -> 1; _ -> 0 }
+     , nb_ps   + case mb_con of { Just (PatSynCon {}) -> 1; _ -> 0 }
+     )
+
+{- Note [Prefer in-scope COMPLETE matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prefer using COMPLETE pragmas in which all ConLikes are in scope, as this
+improves error messages. See for example T25115:
+
+  - T25115a defines pattern Foo :: a with {-# COMPLETE Foo #-}
+  - T25115 imports T25115a, but not Foo.
+    (This means it imports the COMPLETE pragma, which behaves like an instance.)
+
+    Then, for the following incomplete pattern match in T25115:
+
+      baz :: Ordering -> Int
+      baz = \case
+        EQ -> 5
+
+    we would prefer reporting that 'LT' and 'GT' are not matched, rather than
+    saying that 'T25115a.Foo' is not matched.
+
+    However, if ALL ConLikes are out of scope, then we should still report
+    something, so we don't want to outright filter out all COMPLETE sets
+    with an out-of-scope ConLike.
+-}
 
 pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches
 -- See Note [Implementation of COMPLETE pragmas] on what "applicable" means

compiler/GHC/HsToCore/Types.hs

@@ -53,9 +53,9 @@ data DsGblEnv
   = DsGblEnv
   { ds_mod          :: Module             -- For SCC profiling
   , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
-  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype
-                                          -- constructors are in scope during
-                                          -- pattern-match satisfiability checking
+  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed only for the following reasons:
+                                          --    - to know what newtype constructors are in scope
+                                          --    - to check whether all members of a COMPLETE pragma are in scope
   , ds_name_ppr_ctx :: NamePprCtx
   , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages
   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,

compiler/GHC/Parser/Errors/Ppr.hs

@@ -41,7 +41,7 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 instance Diagnostic PsMessage where
   type DiagnosticOpts PsMessage = NoDiagnosticOpts
   diagnosticMessage opts = \case
-    PsUnknownMessage (UnknownDiagnostic f m)
+    PsUnknownMessage (UnknownDiagnostic f _ m)
       -> diagnosticMessage (f opts) m
 
     PsHeaderMessage m

compiler/GHC/Parser/Errors/Types.hs

@@ -68,7 +68,7 @@ data PsMessage
         arbitrary messages to be embedded. The typical use case would be GHC plugins
         willing to emit custom diagnostics.
     -}
-    PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsMessage))
+    PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsMessage) GhcHint)
 
     {-| A group of parser messages emitted in 'GHC.Parser.Header'.
         See Note [Messages from GHC.Parser.Header].

compiler/GHC/SysTools/Cpp.hs

@@ -263,11 +263,17 @@ generateMacros prefix name version =
 -- | Find out path to @ghcversion.h@ file
 getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
 getGhcVersionPathName dflags unit_env = do
-  candidates <- case ghcVersionFile dflags of
-    Just path -> return [path]
-    Nothing -> do
-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
+  let candidates = case ghcVersionFile dflags of
+        -- the user has provided an explicit `ghcversion.h` file to use.
+        Just path -> [path]
+        -- otherwise, try to find it in the rts' include-dirs.
+        -- Note: only in the RTS include-dirs! not all preload units less we may
+        -- use a wrong file. See #25106 where a globally installed
+        -- /usr/include/ghcversion.h file was used instead of the one provided
+        -- by the rts.
+        Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of
+          Nothing   -> []
+          Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]
 
   found <- filterM doesFileExist candidates
   case found of

compiler/GHC/Tc/Errors/Ppr.hs

@@ -141,7 +141,7 @@ instance HasDefaultDiagnosticOpts TcRnMessageOpts where
 instance Diagnostic TcRnMessage where
   type DiagnosticOpts TcRnMessage = TcRnMessageOpts
   diagnosticMessage opts = \case
-    TcRnUnknownMessage (UnknownDiagnostic f m)
+    TcRnUnknownMessage (UnknownDiagnostic f _ m)
       -> diagnosticMessage (f opts) m
     TcRnMessageWithInfo unit_state msg_with_info
       -> case msg_with_info of

compiler/GHC/Tc/Errors/Types.hs

@@ -285,7 +285,7 @@ data TcRnMessageDetailed
                         !TcRnMessage
   deriving Generic
 
-mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts)
+mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint)
                      => a -> TcRnMessage
 mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag)
   -- Please don't use this function inside the GHC codebase;
@@ -299,7 +299,7 @@ data TcRnMessage where
   {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins
       to provide custom diagnostic messages originated during typechecking/renaming.
   -}
-  TcRnUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts TcRnMessage)) -> TcRnMessage
+  TcRnUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts TcRnMessage) GhcHint) -> TcRnMessage
 
   {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface
       files during typechecking but encounter an error. -}

compiler/GHC/Types/Error.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module GHC.Types.Error
    ( -- * Messages
@@ -36,7 +37,6 @@ module GHC.Types.Error
    , DiagnosticMessage (..)
    , DiagnosticReason (WarningWithFlag, ..)
    , ResolvedDiagnosticReason(..)
-   , DiagnosticHint (..)
    , mkPlainDiagnostic
    , mkPlainError
    , mkDecoratedDiagnostic
@@ -167,7 +167,7 @@ instance Diagnostic e => Outputable (Messages e) where
                pprDiagnostic (errMsgDiagnostic envelope)
              ]
 
-instance Diagnostic e => ToJson (Messages e) where
+instance (Diagnostic e) => ToJson (Messages e) where
   json msgs =  JSArray . toList $ json <$> getMessages msgs
 
 {- Note [Discarding Messages]
@@ -247,11 +247,16 @@ defaultDiagnosticOpts = defaultOpts @(DiagnosticOpts opts)
 -- A 'Diagnostic' carries the /actual/ description of the message (which, in
 -- GHC's case, it can be an error or a warning) and the /reason/ why such
 -- message was generated in the first place.
-class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
+class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
 
   -- | Type of configuration options for the diagnostic.
   type DiagnosticOpts a
 
+  -- | Type of hint this diagnostic can provide.
+  -- by default this is 'GhcHint'
+  type DiagnosticHint a
+  type DiagnosticHint a = GhcHint
+
   -- | Extract the error message text from a 'Diagnostic'.
   diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
 
@@ -261,7 +266,7 @@ class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
 
   -- | Extract any hints a user might use to repair their
   -- code to avoid this diagnostic.
-  diagnosticHints   :: a -> [GhcHint]
+  diagnosticHints   :: a -> [DiagnosticHint a]
 
   -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'.
   -- This can return 'Nothing' for at least two reasons:
@@ -278,19 +283,21 @@ class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
   diagnosticCode    :: a -> Maybe DiagnosticCode
 
 -- | An existential wrapper around an unknown diagnostic.
-data UnknownDiagnostic opts where
+data UnknownDiagnostic opts hint where
   UnknownDiagnostic :: (Diagnostic a, Typeable a)
                     => (opts -> DiagnosticOpts a) -- Inject the options of the outer context
                                                   -- into the options for the wrapped diagnostic.
+                    -> (DiagnosticHint a -> hint)
                     -> a
-                    -> UnknownDiagnostic opts
+                    -> UnknownDiagnostic opts hint
 
-instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where
-  type DiagnosticOpts (UnknownDiagnostic opts) = opts
-  diagnosticMessage opts (UnknownDiagnostic f diag) = diagnosticMessage (f opts) diag
-  diagnosticReason    (UnknownDiagnostic _ diag) = diagnosticReason  diag
-  diagnosticHints     (UnknownDiagnostic _ diag) = diagnosticHints   diag
-  diagnosticCode      (UnknownDiagnostic _ diag) = diagnosticCode    diag
+instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (UnknownDiagnostic opts hint) where
+  type DiagnosticOpts (UnknownDiagnostic opts _) = opts
+  type DiagnosticHint (UnknownDiagnostic _ hint) = hint
+  diagnosticMessage opts (UnknownDiagnostic f _ diag) = diagnosticMessage (f opts) diag
+  diagnosticReason       (UnknownDiagnostic _ _ diag) = diagnosticReason diag
+  diagnosticHints        (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag)
+  diagnosticCode         (UnknownDiagnostic _ _ diag) = diagnosticCode diag
 
 -- A fallback 'DiagnosticOpts' which can be used when there are no options
 -- for a particular diagnostic.
@@ -299,16 +306,18 @@ instance HasDefaultDiagnosticOpts NoDiagnosticOpts where
   defaultOpts = NoDiagnosticOpts
 
 -- | Make a "simple" unknown diagnostic which doesn't have any configuration options.
-mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b
-mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts)
+mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint) =>
+  a -> UnknownDiagnostic b GhcHint
+mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts) id
 
 -- | Make an unknown diagnostic which uses the same options as the context it will be embedded into.
-mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)
-mkUnknownDiagnostic = UnknownDiagnostic id
+mkUnknownDiagnostic :: (Typeable a, Diagnostic a, DiagnosticHint a ~ GhcHint) =>
+  a -> UnknownDiagnostic (DiagnosticOpts a) GhcHint
+mkUnknownDiagnostic = UnknownDiagnostic id id
 
 -- | Embed a more complicated diagnostic which requires a potentially different options type.
-embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
-embedUnknownDiagnostic = UnknownDiagnostic
+embedUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticHint a ~ GhcHint) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts GhcHint
+embedUnknownDiagnostic f = UnknownDiagnostic f id
 
 --------------------------------------------------------------------------------
 
@@ -317,11 +326,6 @@ pprDiagnostic e = vcat [ ppr (diagnosticReason e)
                        , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ]
   where opts = defaultDiagnosticOpts @e
 
--- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.
-data DiagnosticHint = DiagnosticHint !SDoc
-
-instance Outputable DiagnosticHint where
-  ppr (DiagnosticHint msg) = msg
 
 -- | A generic 'Diagnostic' message, without any further classification or
 -- provenance: By looking at a 'DiagnosticMessage' we don't know neither
@@ -578,7 +582,7 @@ https://json-schema.org
 schemaVersion :: String
 schemaVersion = "1.0"
 -- See Note [Diagnostic Message JSON Schema] before editing!
-instance Diagnostic e => ToJson (MsgEnvelope e) where
+instance (Diagnostic e) => ToJson (MsgEnvelope e) where
   json m = JSObject [
     ("version", JSString schemaVersion),
     ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),

compiler/GHC/Types/Error/Codes.hs

@@ -30,7 +30,7 @@ import GHC.Prelude
 import GHC.Core.InstEnv         ( LookupInstanceErrReason )
 import GHC.Hs.Extension         ( GhcRn )
 import GHC.Types.Error          ( DiagnosticCode(..), UnknownDiagnostic (..), NoDiagnosticOpts
-                                , diagnosticCode )
+                                , diagnosticCode, GhcHint )
 import GHC.Unit.Module.Warnings ( WarningTxt )
 import GHC.Utils.Panic.Plain
 
@@ -1015,12 +1015,12 @@ type family ConRecursInto con where
   ConRecursInto "GhcPsMessage"             = 'Just PsMessage
   ConRecursInto "GhcTcRnMessage"           = 'Just TcRnMessage
   ConRecursInto "GhcDsMessage"             = 'Just DsMessage
-  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnostic GhcMessageOpts)
+  ConRecursInto "GhcUnknownMessage"        = 'Just (UnknownDiagnostic GhcMessageOpts GhcHint)
 
   ----------------------------------
   -- Constructors of DriverMessage
 
-  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnostic DriverMessageOpts)
+  ConRecursInto "DriverUnknownMessage"     = 'Just (UnknownDiagnostic DriverMessageOpts GhcHint)
   ConRecursInto "DriverPsHeaderMessage"    = 'Just PsMessage
   ConRecursInto "DriverInterfaceError"     = 'Just IfaceMessage
 
@@ -1035,13 +1035,13 @@ type family ConRecursInto con where
   ----------------------------------
   -- Constructors of PsMessage
 
-  ConRecursInto "PsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts)
+  ConRecursInto "PsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts GhcHint)
   ConRecursInto "PsHeaderMessage"          = 'Just PsHeaderMessage
 
   ----------------------------------
   -- Constructors of TcRnMessage
 
-  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnostic TcRnMessageOpts)
+  ConRecursInto "TcRnUnknownMessage"       = 'Just (UnknownDiagnostic TcRnMessageOpts GhcHint)
 
     -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage
   ConRecursInto "TcRnMessageWithInfo"      = 'Just TcRnMessageDetailed
@@ -1136,7 +1136,7 @@ type family ConRecursInto con where
   ----------------------------------
   -- Constructors of DsMessage
 
-  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts)
+  ConRecursInto "DsUnknownMessage"         = 'Just (UnknownDiagnostic NoDiagnosticOpts GhcHint)
 
   ----------------------------------
   -- Constructors of ImportLookupBad
@@ -1232,14 +1232,14 @@ class ConstructorCodes namespace con f seen recur where
 -- If we recur into the 'UnknownDiagnostic' existential datatype,
 -- unwrap the existential and obtain the error code.
 instance {-# OVERLAPPING #-}
-         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts)
-         , HasType namespace (UnknownDiagnostic opts) con f )
-      => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts)) where
-  gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts) @con @f diag of
-    UnknownDiagnostic _ diag -> diagnosticCode diag
+         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint)
+         , HasType namespace (UnknownDiagnostic opts hint) con f )
+      => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts hint)) where
+  gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts hint) @con @f diag of
+    UnknownDiagnostic _ _ diag -> diagnosticCode diag
 instance {-# OVERLAPPING #-}
-         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts) )
-      => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts)) where
+         ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) )
+      => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts hint)) where
   gconstructorCodes = Map.empty
 
 -- | (*) Base instance: use the diagnostic code for this constructor in this namespace.

compiler/GHC/Types/Unique/Supply.hs

@@ -4,6 +4,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UnboxedTuples #-}
@@ -41,6 +42,7 @@ import Control.Monad
 import Data.Word
 import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
 import Foreign.Storable
+import GHC.Utils.Monad.State.Strict as Strict
 
 #include "MachDeps.h"
 
@@ -304,6 +306,8 @@ uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily n
 uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
 
+{-# INLINE splitUniqSupply #-}
+
 {-
 ************************************************************************
 *                                                                      *
@@ -320,12 +324,7 @@ pattern UniqResult x y = (# x, y #)
 
 -- | A monad which just gives the ability to obtain 'Unique's
 newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
-
--- See Note [The one-shot state monad trick] for why we don't derive this.
-instance Functor UniqSM where
-  fmap f (USM m) = mkUniqSM $ \us ->
-      case m us of
-        (# r, us' #) -> UniqResult (f r) us'
+  deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply)
 
 -- | Smart constructor for 'UniqSM', as described in Note [The one-shot state
 -- monad trick].
@@ -333,17 +332,6 @@ mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a
 mkUniqSM f = USM (oneShot f)
 {-# INLINE mkUniqSM #-}
 
-instance Monad UniqSM where
-  (>>=) = thenUs
-  (>>)  = (*>)
-
-instance Applicative UniqSM where
-    pure = returnUs
-    (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of
-                            UniqResult ff us1 -> case x us1 of
-                              UniqResult xx us2 -> UniqResult (ff xx) us2
-    (*>) = thenUs_
-
 -- TODO: try to get rid of this instance
 instance MonadFail UniqSM where
     fail = panic
@@ -356,30 +344,12 @@ initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) }
 initUs_ :: UniqSupply -> UniqSM a -> a
 initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r }
 
-{-# INLINE thenUs #-}
-{-# INLINE returnUs #-}
-{-# INLINE splitUniqSupply #-}
-
--- @thenUs@ is where we split the @UniqSupply@.
-
 liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
 liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)
 
 instance MonadFix UniqSM where
     mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)
 
-thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-thenUs (USM expr) cont
-  = mkUniqSM (\us0 -> case (expr us0) of
-                   UniqResult result us1 -> unUSM (cont result) us1)
-
-thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
-thenUs_ (USM expr) (USM cont)
-  = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })
-
-returnUs :: a -> UniqSM a
-returnUs result = mkUniqSM (\us -> UniqResult result us)
-
 getUs :: UniqSM UniqSupply
 getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)