[Git][ghc/ghc][wip/T25647] 35 commits: base: Label threads forked by IO operations

Sat Feb 8 20:37:07 UTC 2025

Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC


Commits:
8f8d3a90 by Ben Gamari at 2025-02-08T01:17:28-05:00
base: Label threads forked by IO operations

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
28600825 by Ben Gamari at 2025-02-08T01:17:28-05:00
base: Label threads forked by System.Timeout

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
8a249827 by Ben Gamari at 2025-02-08T01:17:28-05:00
base: Label signal handling threads

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
26af26f0 by Ben Gamari at 2025-02-08T01:17:28-05:00
base: Label Windows console event handling threads

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
bf9c3d4f by Ben Gamari at 2025-02-08T01:17:28-05:00
ghci: Label evaluation sandbox thread

Addresses part of #25452.

Addresses core-libraries-committee#305.

- - - - -
38f78ce5 by Ben Gamari at 2025-02-08T01:17:28-05:00
base: Add changelog entry for addition of thread labels

Addresses #25452.

Addresses core-libraries-committee#305.

- - - - -
c100deb5 by Ben Gamari at 2025-02-08T01:18:05-05:00
gen-ci: Clean up style

This cleans up a number of stylistic inconsistencies although it's still
far from perfect.

- - - - -
c4a7680a by Ben Gamari at 2025-02-08T01:18:05-05:00
gen-ci: Properly encapsulate GitLab predicates

- - - - -
72d14be7 by Simon Peyton Jones at 2025-02-08T20:36:39+00:00
WIP towards #25267

- - - - -
e71a4fb6 by Simon Peyton Jones at 2025-02-08T20:36:39+00:00
Wibbles

- - - - -
5755d1b5 by Simon Peyton Jones at 2025-02-08T20:36:39+00:00
Default tyvars in data/newtype insnstances

This is what fixes #25647

- - - - -
94962fe9 by Simon Peyton Jones at 2025-02-08T20:36:39+00:00
wibbles

Including fix for #25725

- - - - -
1a1ac919 by Simon Peyton Jones at 2025-02-08T20:36:39+00:00
Wibble

- - - - -
632c88ce by Patrick at 2025-02-08T20:36:39+00:00
add more tests

- - - - -
899f7590 by Patrick at 2025-02-08T20:36:39+00:00
Fix up T25611d with explicit kind annotation

- - - - -
57746293 by Patrick at 2025-02-08T20:36:39+00:00
fix up T25647_fail

- - - - -
c24c7bd5 by Patrick at 2025-02-08T20:36:39+00:00
cleanup whitespace

- - - - -
b005ce2a by Patrick at 2025-02-08T20:36:39+00:00
fix up T23512a

- - - - -
2ff9e2c8 by Patrick at 2025-02-08T20:36:39+00:00
add more examples to T25647b

- - - - -
56d57a2a by Patrick at 2025-02-08T20:36:39+00:00
add Dix6 to T25647_fail

- - - - -
0431d5b0 by Patrick at 2025-02-08T20:36:39+00:00
add Dix7 for T25647a

- - - - -
dabcbc77 by Patrick at 2025-02-08T20:36:39+00:00
change DefaultingStrategy of tcTyFamInstEqnGuts as well

- - - - -
73ec0074 by Patrick at 2025-02-08T20:36:39+00:00
align wildcard with named typevar on wether it is skolem

- - - - -
42452076 by Patrick at 2025-02-08T20:36:39+00:00
fix T17536c

- - - - -
cfa92439 by Patrick at 2025-02-08T20:36:39+00:00
Fix T9357

- - - - -
49161a84 by Patrick at 2025-02-08T20:36:39+00:00
remove wildcard usage

- - - - -
5d6aec85 by Patrick at 2025-02-08T20:36:39+00:00
Revert "align wildcard with named typevar on wether it is skolem"

This reverts commit d1f61858328cc190de9b34c9a24e8d6b28ee5fa9.

- - - - -
d2aa8e86 by Patrick at 2025-02-08T20:36:39+00:00
add WildCardTv to forbid wildcard from defaulting

- - - - -
cb661de1 by Patrick at 2025-02-08T20:36:39+00:00
Fix wildcard related tests

- - - - -
c54624db by Patrick at 2025-02-08T20:36:39+00:00
add wildcards testcase for T25647a

- - - - -
5d234718 by Patrick at 2025-02-08T20:36:39+00:00
Fix T25647a

- - - - -
f5abbf3a by Patrick at 2025-02-08T20:36:39+00:00
Revert "Fix wildcard related tests"

This reverts commit 8756ab87f4e3d74968d3937f84f811f78a861852.

- - - - -
1ff3327f by Patrick at 2025-02-08T20:36:39+00:00
limit WildCardTv to only HM_FamPat

- - - - -
28528ae1 by Patrick at 2025-02-08T20:36:39+00:00
fix

- - - - -
88dfabaa by Patrick at 2025-02-08T20:36:39+00:00
Revert "remove wildcard usage"

This reverts commit ccc9152f23177ab7a542852ffedf626edcdcef95.

- - - - -


30 changed files:

- .gitlab/generate-ci/gen_ci.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- libraries/base/changelog.md
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/System/Timeout.hs
- libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
- libraries/ghci/GHCi/Run.hs
- + testsuite/tests/indexed-types/should_compile/T11450a.hs
- testsuite/tests/indexed-types/should_compile/T25611d.hs
- testsuite/tests/indexed-types/should_compile/all.T
- testsuite/tests/indexed-types/should_fail/T9357.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/rename/should_fail/T23512a.stderr
- + testsuite/tests/typecheck/should_compile/T25647_fail.hs
- + testsuite/tests/typecheck/should_compile/T25647_fail.stderr
- + testsuite/tests/typecheck/should_compile/T25647a.hs
- + testsuite/tests/typecheck/should_compile/T25647b.hs
- + testsuite/tests/typecheck/should_compile/T25725.hs
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -5,6 +5,12 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ViewPatterns #-}
 
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+{-# HLINT ignore "Use camelCase" #-}
+{-# LANGUAGE DerivingStrategies #-}
+
 import Data.Aeson as A
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -199,7 +205,7 @@ data FlavourTrans =
 data BaseFlavour = Release | Validate | SlowValidate deriving Eq
 
 -----------------------------------------------------------------------------

--- Build Configs
+-- Build Configurations
 -----------------------------------------------------------------------------
 
 -- | A standard build config
@@ -244,7 +250,7 @@ releaseConfig = vanilla { buildFlavour = Release }
 debug :: BuildConfig
 debug = vanilla { buildFlavour = SlowValidate
                 , withAssertions = True
-                -- WithNuma so at least one job tests Numa
+                  -- WithNuma so at least one job tests Numa
                 , withNuma = True
                 }
 
@@ -280,21 +286,21 @@ usePerfProfilingTestsuite :: BuildConfig -> BuildConfig
 usePerfProfilingTestsuite bc = bc { testsuiteUsePerf = True }
 
 -----------------------------------------------------------------------------
--- Platform specific variables
+-- Identifying Platforms
 -----------------------------------------------------------------------------
 
 -- | These tags have to match what we call the runners on gitlab
 runnerTag :: Arch -> Opsys -> String
 runnerTag arch (Linux _) =
   case arch of
-    Amd64   -> "x86_64-linux"
-    AArch64 -> "aarch64-linux"
-    I386    -> "x86_64-linux"
-runnerTag AArch64 Darwin = "aarch64-darwin"
-runnerTag Amd64 Darwin = "x86_64-darwin-m1"
-runnerTag Amd64 Windows = "new-x86_64-windows"
+    Amd64                -> "x86_64-linux"
+    AArch64              -> "aarch64-linux"
+    I386                 -> "x86_64-linux"
+runnerTag AArch64 Darwin  = "aarch64-darwin"
+runnerTag Amd64 Darwin    = "x86_64-darwin-m1"
+runnerTag Amd64 Windows   = "new-x86_64-windows"
 runnerTag Amd64 FreeBSD14 = "x86_64-freebsd14"
-runnerTag _ _ = error "Invalid arch/opsys"
+runnerTag _ _             = error "Invalid arch/opsys"
 
 tags :: Arch -> Opsys -> BuildConfig -> [String]
 tags arch opsys _bc = [runnerTag arch opsys] -- Tag for which runners we can use
@@ -305,34 +311,34 @@ runnerPerfTag arch sys = runnerTag arch sys ++ "-perf"
 -- These names are used to find the docker image so they have to match what is
 -- in the docker registry.
 distroName :: LinuxDistro -> String
-distroName Debian12   = "deb12"
-distroName Debian11   = "deb11"
-distroName Debian11Js = "deb11-emsdk-closure"
+distroName Debian12      = "deb12"
+distroName Debian11      = "deb11"
+distroName Debian11Js    = "deb11-emsdk-closure"
 distroName Debian12Riscv = "deb12-riscv"
-distroName Debian10   = "deb10"
-distroName Debian9    = "deb9"
-distroName Fedora33   = "fedora33"
-distroName Fedora38   = "fedora38"
-distroName Ubuntu1804 = "ubuntu18_04"
-distroName Ubuntu2004 = "ubuntu20_04"
-distroName Ubuntu2204 = "ubuntu22_04"
-distroName Centos7    = "centos7"
-distroName Alpine312  = "alpine3_12"
-distroName Alpine318  = "alpine3_18"
-distroName Alpine320  = "alpine3_20"
-distroName AlpineWasm = "alpine3_20-wasm"
-distroName Rocky8     = "rocky8"
+distroName Debian10      = "deb10"
+distroName Debian9       = "deb9"
+distroName Fedora33      = "fedora33"
+distroName Fedora38      = "fedora38"
+distroName Ubuntu1804    = "ubuntu18_04"
+distroName Ubuntu2004    = "ubuntu20_04"
+distroName Ubuntu2204    = "ubuntu22_04"
+distroName Centos7       = "centos7"
+distroName Alpine312     = "alpine3_12"
+distroName Alpine318     = "alpine3_18"
+distroName Alpine320     = "alpine3_20"
+distroName AlpineWasm    = "alpine3_20-wasm"
+distroName Rocky8        = "rocky8"
 
 opsysName :: Opsys -> String
 opsysName (Linux distro) = "linux-" ++ distroName distro
-opsysName Darwin = "darwin"
-opsysName FreeBSD14 = "freebsd14"
-opsysName Windows = "windows"
+opsysName Darwin         = "darwin"
+opsysName FreeBSD14      = "freebsd14"
+opsysName Windows        = "windows"
 
 archName :: Arch -> String
-archName Amd64 = "x86_64"
+archName Amd64   = "x86_64"
 archName AArch64 = "aarch64"
-archName I386  = "i386"
+archName I386    = "i386"
 
 binDistName :: Arch -> Opsys -> BuildConfig -> String
 binDistName arch opsys bc = "ghc-" ++ testEnv arch opsys bc
@@ -341,16 +347,18 @@ binDistName arch opsys bc = "ghc-" ++ testEnv arch opsys bc
 -- Either the change is reflected by modifying the flavourString or directly (as is
 -- the case for settings which affect environment variables)
 testEnv :: Arch -> Opsys -> BuildConfig -> String
-testEnv arch opsys bc = intercalate "-" $
-                        [ archName arch
-                        , opsysName opsys ]
-                        ++ ["int_" ++ bignumString (bignumBackend bc) | bignumBackend bc /= Gmp]
-                        ++ ["unreg" | unregisterised bc ]
-                        ++ ["numa"  | withNuma bc ]
-                        ++ ["zstd"  | withZstd bc ]
-                        ++ ["no_tntc"  | not (tablesNextToCode bc) ]
-                        ++ ["cross_"++triple  | Just triple <- pure $ crossTarget bc ]
-                        ++ [flavourString (mkJobFlavour bc)]
+testEnv arch opsys bc =
+  intercalate "-" $ concat
+    [ [ archName arch
+      , opsysName opsys ]
+    , ["int_" ++ bignumString (bignumBackend bc) | bignumBackend bc /= Gmp]
+    , ["unreg" | unregisterised bc ]
+    , ["numa"  | withNuma bc ]
+    , ["zstd"  | withZstd bc ]
+    , ["no_tntc"  | not (tablesNextToCode bc) ]
+    , ["cross_"++triple  | Just triple <- pure $ crossTarget bc ]
+    , [flavourString (mkJobFlavour bc)]
+    ]
 
 -- | The hadrian flavour string we are going to use for this build
 flavourString :: Flavour -> String
@@ -384,7 +392,7 @@ dockerImage arch (Linux distro) =
 dockerImage _ _ = Nothing
 
 -----------------------------------------------------------------------------
--- Platform specific variables
+-- Platform-specific variables
 -----------------------------------------------------------------------------
 
 -- The variables map is a monoidal map so that we don't ever accidentally lose
@@ -438,35 +446,36 @@ opsysVariables _ FreeBSD14 = mconcat
   , "CABAL_INSTALL_VERSION" =: "3.10.3.0"
   ]
 opsysVariables arch (Linux distro) = distroVariables arch distro
-opsysVariables AArch64 (Darwin {}) =
-  mconcat [ "NIX_SYSTEM" =: "aarch64-darwin"
-          , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
-          , "LANG" =: "en_US.UTF-8"
-          , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
-          -- Fonts can't be installed on darwin
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
-          ]
-opsysVariables Amd64 (Darwin {}) =
-  mconcat [ "NIX_SYSTEM" =: "x86_64-darwin"
-          , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
-          -- "# Only Sierra and onwards supports clock_gettime. See #12858"
-          , "ac_cv_func_clock_gettime" =: "no"
-          -- # Only newer OS Xs support utimensat. See #17895
-          , "ac_cv_func_utimensat" =: "no"
-          -- # Only newer OS Xs support futimens. See #22938
-          , "ac_cv_func_futimens" =: "no"
-          , "LANG" =: "en_US.UTF-8"
-          , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
-          -- Fonts can't be installed on darwin
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+opsysVariables AArch64 (Darwin {}) = mconcat
+  [ "NIX_SYSTEM" =: "aarch64-darwin"
+  , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
+  , "LANG" =: "en_US.UTF-8"
+  , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
+    -- Fonts can't be installed on darwin
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+  ]
+opsysVariables Amd64 (Darwin {}) = mconcat
+  [ "NIX_SYSTEM" =: "x86_64-darwin"
+  , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
+    -- Only Sierra and onwards supports clock_gettime. See #12858
+  , "ac_cv_func_clock_gettime" =: "no"
+    -- Only newer OS Xs support utimensat. See #17895
+  , "ac_cv_func_utimensat" =: "no"
+    -- Only newer OS Xs support futimens. See #22938
+  , "ac_cv_func_futimens" =: "no"
+  , "LANG" =: "en_US.UTF-8"
+  , "CONFIGURE_ARGS" =: "--with-intree-gmp --with-system-libffi"
+    -- Fonts can't be installed on darwin
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
 
-          ]
-opsysVariables _ (Windows {}) =
-  mconcat [ "MSYSTEM" =: "CLANG64"
-          , "LANG" =: "en_US.UTF-8"
-          , "CABAL_INSTALL_VERSION" =: "3.10.2.0"
-          , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
-          , "GHC_VERSION" =: "9.6.4" ]
+  ]
+opsysVariables _ (Windows {}) = mconcat
+  [ "MSYSTEM" =: "CLANG64"
+  , "LANG" =: "en_US.UTF-8"
+  , "CABAL_INSTALL_VERSION" =: "3.10.2.0"
+  , "HADRIAN_ARGS" =: "--docs=no-sphinx-pdfs"
+  , "GHC_VERSION" =: "9.6.4"
+  ]
 opsysVariables _ _ = mempty
 
 alpineVariables :: Arch -> Variables
@@ -481,7 +490,7 @@ alpineVariables arch = mconcat $
   | I386 <- [arch]
   ] ++
   [ brokenTest "T22033" "#25497" | I386 <- [arch] ] ++
-  [-- Bootstrap compiler has incorrectly configured target triple #25200
+  [ -- Bootstrap compiler has incorrectly configured target triple #25200
     "CONFIGURE_ARGS" =: "--enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux"
   | AArch64 <- [arch]
   ]
@@ -491,15 +500,14 @@ distroVariables :: Arch -> LinuxDistro -> Variables
 distroVariables arch Alpine312 = alpineVariables arch
 distroVariables arch Alpine318 = alpineVariables arch
 distroVariables arch Alpine320 = alpineVariables arch
-distroVariables _ Centos7 = mconcat [
-    "HADRIAN_ARGS" =: "--docs=no-sphinx"
-  , brokenTest "T22012" "#23979"
-  ]
-distroVariables _ Fedora33 = mconcat
+distroVariables _    Centos7   = mconcat [ "HADRIAN_ARGS" =: "--docs=no-sphinx"
+                                         , brokenTest "T22012" "#23979"
+                                         ]
+distroVariables _    Fedora33  = mconcat
   -- LLC/OPT do not work for some reason in our fedora images
   -- These tests fail with this error: T11649 T5681 T7571 T8131b
   -- +/opt/llvm/bin/opt: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/opt)
--- +/opt/llvm/bin/llc: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/llc)
+  -- +/opt/llvm/bin/llc: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/llc)
   [ "LLC" =: "/bin/false"
   , "OPT" =: "/bin/false"
   ]
@@ -510,7 +518,7 @@ distroVariables _ _ = mempty
 -----------------------------------------------------------------------------
 
 data Cache
-  = Cache { cacheKey :: String
+  = Cache { cacheKey   :: String
           , cachePaths :: [String]
           }
 
@@ -550,25 +558,27 @@ data ArtifactsWhen = ArtifactsOnSuccess | ArtifactsOnFailure | ArtifactsAlways
 instance ToJSON ArtifactsWhen where
   toJSON ArtifactsOnSuccess = "on_success"
   toJSON ArtifactsOnFailure = "on_failure"
-  toJSON ArtifactsAlways = "always"
+  toJSON ArtifactsAlways    = "always"
 
------------------------------------------------------------------------------
+---------------------------------------------------------------------
 -- Rules, when do we run a job
------------------------------------------------------------------------------
+---------------------------------------------------------------------
 
--- Data structure which records the condition when a job is run.
-data OnOffRules = OnOffRules { rule_set :: Rule -- ^ The enabled rules
-                             , when :: ManualFlag   -- ^ The additional condition about when to run this job.
-                             }
+-- | Data structure which records the condition when a job is run.
+data OnOffRules
+  = OnOffRules { rule_set :: Rule -- ^ The enabled rules
+               , when     :: ManualFlag   -- ^ The additional condition about when to run this job.
+               }
 
 -- The initial set of rules, which assumes a Validate pipeline which is run with FullCI.
 emptyRules :: String -> OnOffRules
 emptyRules jobName = OnOffRules (ValidateOnly jobName (S.fromList [FullCI])) OnSuccess
 
 -- When to run the job
-data ManualFlag = Manual -- ^ Only run the job when explicitly triggered by a user
-                | OnSuccess -- ^ Always run it, if the rules pass (the default)
-                deriving Eq
+data ManualFlag
+  = Manual -- ^ Only run the job when explicitly triggered by a user
+  | OnSuccess -- ^ Always run it, if the rules pass (the default)
+  deriving Eq
 
 setRule :: Rule -> OnOffRules -> OnOffRules
 setRule r (OnOffRules _ m) = OnOffRules r m
@@ -595,18 +605,23 @@ manualRule rules = rules { when = Manual }
 enumRules :: OnOffRules -> [OnOffRule]
 enumRules (OnOffRules r _) = rulesList
   where
-    rulesList = case r of
-                  ValidateOnly s rs -> [OnOffRule On (ValidateOnly s rs)
-                                    , OnOffRule Off ReleaseOnly
-                                    , OnOffRule Off Nightly ]
-                  Nightly -> [ OnOffRule Off (ValidateOnly "" S.empty)
-                             , OnOffRule Off ReleaseOnly
-                             , OnOffRule On Nightly ]
-                  ReleaseOnly -> [ OnOffRule Off (ValidateOnly "" S.empty)
-                                 , OnOffRule On ReleaseOnly
-                                 , OnOffRule Off Nightly ]
-
-
+    rulesList =
+      case r of
+        ValidateOnly s rs ->
+          [ OnOffRule On (ValidateOnly s rs)
+          , OnOffRule Off ReleaseOnly
+          , OnOffRule Off Nightly
+          ]
+        Nightly ->
+          [ OnOffRule Off (ValidateOnly "" S.empty)
+          , OnOffRule Off ReleaseOnly
+          , OnOffRule On Nightly
+          ]
+        ReleaseOnly ->
+          [ OnOffRule Off (ValidateOnly "" S.empty)
+          , OnOffRule On ReleaseOnly
+          , OnOffRule Off Nightly
+          ]
 
 data OnOffRule = OnOffRule OnOff Rule
 
@@ -617,102 +632,135 @@ instance ToJSON ManualFlag where
   toJSON OnSuccess = "on_success"
 
 instance ToJSON OnOffRules where
-  toJSON rules = toJSON [object ([
-    "if" A..= and_all (map one_rule (enumRules rules))
-    , "when" A..= toJSON (when rules)]
-    -- Necessary to stop manual jobs stopping pipeline progress
-    -- https://docs.gitlab.com/ee/ci/yaml/#rulesallow_failure
-    ++
-    ["allow_failure" A..= True | when rules == Manual ])]
-
+  toJSON rules = toJSON
+      [object $
+        [ "if" A..= and_all (map one_rule (enumRules rules))
+        , "when" A..= toJSON (when rules)
+        ] ++
+        -- Necessary to stop manual jobs stopping pipeline progress
+        -- https://docs.gitlab.com/ee/ci/yaml/#rulesallow_failure
+        [ "allow_failure" A..= True | when rules == Manual ]
+      ]
     where
-      one_rule (OnOffRule onoff r) = ruleString onoff r
+      one_rule (OnOffRule onoff r) = ruleToCond onoff r
 
+---------------------------------------------------------------------
+-- Rule conditions
+---------------------------------------------------------------------
 
-parens :: [Char] -> [Char]
-parens s = "(" ++ s ++ ")"
-and_all :: [[Char]] -> [Char]
-and_all rs = intercalate " && " (map parens rs)
-or_all :: [[Char]] -> [Char]
-or_all rs = intercalate " || " (map parens rs)
+-- | A predicate in GitLab's rules language.
+newtype Cond = Cond { getCond :: String }
+  deriving newtype (ToJSON)
 
--- | A Rule corresponds to some condition which must be satisifed in order to
--- run the job.
-data Rule = ReleaseOnly  -- ^ Only run this job in a release pipeline
-          | Nightly      -- ^ Only run this job in the nightly pipeline
-          | ValidateOnly String (S.Set ValidateRule) -- ^ Only run this job in a validate pipeline, when any of these rules are enabled.
-          deriving (Show, Ord, Eq)
-
-data ValidateRule =
-            FullCI       -- ^ Run this job when the "full-ci" label is present.
-          | FastCI       -- ^ Run this job on every validation pipeline
-          | LLVMBackend  -- ^ Run this job when the "LLVM backend" label is present
-          | JSBackend    -- ^ Run this job when the "javascript" label is present
-          | RiscV        -- ^ Run this job when the "RISC-V" label is present
-          | WasmBackend  -- ^ Run this job when the "wasm" label is present
-          | FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
-          | NonmovingGc  -- ^ Run this job when the "non-moving GC" label is set.
-          | IpeData      -- ^ Run this job when the "IPE" label is set
-          | TestPrimops  -- ^ Run this job when "test-primops" label is set
-          | I386Backend  -- ^ Run this job when the "i386" label is set
-          deriving (Show, Ord, Eq)
-
--- A constant evaluating to True because gitlab doesn't support "true" in the
+parens :: Cond -> Cond
+parens (Cond s) = Cond $ "(" ++ s ++ ")"
+
+and_all :: [Cond] -> Cond
+and_all =
+  Cond . intercalate " && " . map (getCond . parens)
+
+or_all :: [Cond] -> Cond
+or_all =
+  Cond . intercalate " || " . map (getCond . parens)
+
+type Var = String
+
+varIsSet :: Var -> Cond
+varIsSet var =
+  Cond $ "$" <> var
+
+-- | A constant evaluating to True because gitlab doesn't support "true" in the
 -- expression language.
-true :: String
-true =  "\"true\" == \"true\""
--- A constant evaluating to False because gitlab doesn't support "true" in the
+true :: Cond
+true = Cond "\"true\" == \"true\""
+
+-- | A constant evaluating to False because gitlab doesn't support "true" in the
 -- expression language.
-_false :: String
-_false = "\"disabled\" != \"disabled\""
-
--- Convert the state of the rule into a string that gitlab understand.
-ruleString :: OnOff -> Rule -> String
-ruleString On (ValidateOnly only_job_name vs) =
-  let conds = S.toList vs
-      empty_only_job = envVarNull "ONLY_JOBS"
-      run_cond = case conds of
-                  [] -> _false
-                  cs -> or_all (map validateRuleString conds)
-      escape :: String -> String
-      escape = concatMap (\c -> if c == '+' then "\\+" else [c])
-
-  in
-    or_all  [
-    -- 1. Case when ONLY_JOBS is set
-      and_all [ "$ONLY_JOBS", "$ONLY_JOBS =~ /.*\\b" ++  escape only_job_name ++ "(\\s|$).*/" ]
-    -- 2. Case when ONLY_JOBS is null
-    , and_all [ empty_only_job, run_cond ]
-    ]
-ruleString Off (ValidateOnly {}) = true
-ruleString On ReleaseOnly = "$RELEASE_JOB == \"yes\""
-ruleString Off ReleaseOnly = "$RELEASE_JOB != \"yes\""
-ruleString On Nightly = "$NIGHTLY"
-ruleString Off Nightly = envVarNull "NIGHTLY"
+_false :: Cond
+_false = Cond "\"disabled\" != \"disabled\""
+
+labelString :: String -> Cond
+labelString s =
+  Cond $ "$CI_MERGE_REQUEST_LABELS =~ /.*" ++ s ++ ".*/"
 
-labelString :: String -> String
-labelString s =  "$CI_MERGE_REQUEST_LABELS =~ /.*" ++ s ++ ".*/"
+branchStringExact :: String -> Cond
+branchStringExact =
+  varEqString "CI_COMMIT_BRANCH"
 
-branchStringExact :: String -> String
-branchStringExact s = envVarString "CI_COMMIT_BRANCH" s
+branchStringLike :: String -> Cond
+branchStringLike s =
+  Cond $ "$CI_COMMIT_BRANCH =~ /" ++ s ++ "/"
 
-branchStringLike :: String -> String
-branchStringLike s = "$CI_COMMIT_BRANCH =~ /" ++ s ++ "/"
+varEqString :: String -> String -> Cond
+varEqString var s =
+  Cond $ "$" ++ var ++ " == \"" ++ s ++ "\""
 
-envVarString :: String -> String -> String
-envVarString var s = "$" ++ var ++ " == \"" ++ s ++ "\""
+varNeString :: String -> String -> Cond
+varNeString var s =
+  Cond $ "$" ++ var ++ " != \"" ++ s ++ "\""
 
-envVarNull :: String ->  String
-envVarNull var = "$" ++ var ++ " == null"
+varIsNull :: String -> Cond
+varIsNull var =
+  Cond $ "$" ++ var ++ " == null"
 
+---------------------------------------------------------------------
+-- Our Rules
+---------------------------------------------------------------------
 
-validateRuleString :: ValidateRule -> String
-validateRuleString FullCI = or_all ([ labelString "full-ci"
-                                    , labelString "marge_bot_batch_merge_job"
-                                    , branchStringExact "master"
-                                    , branchStringLike "ghc-[0-9]+\\.[0-9]+"
-                                    ])
-validateRuleString FastCI = true
+-- | A Rule corresponds to some condition which must be satisifed in order to
+-- run the job.
+data Rule
+  = ReleaseOnly  -- ^ Only run this job in a release pipeline
+  | Nightly      -- ^ Only run this job in the nightly pipeline
+  | ValidateOnly String (S.Set ValidateRule) -- ^ Only run this job in a validate pipeline, when any of these rules are enabled.
+  deriving (Show, Ord, Eq)
+
+data ValidateRule
+  = FullCI       -- ^ Run this job when the "full-ci" label is present.
+  | FastCI       -- ^ Run this job on every validation pipeline
+  | LLVMBackend  -- ^ Run this job when the "LLVM backend" label is present
+  | JSBackend    -- ^ Run this job when the "javascript" label is present
+  | RiscV        -- ^ Run this job when the "RISC-V" label is present
+  | WasmBackend  -- ^ Run this job when the "wasm" label is present
+  | FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
+  | NonmovingGc  -- ^ Run this job when the "non-moving GC" label is set.
+  | IpeData      -- ^ Run this job when the "IPE" label is set
+  | TestPrimops  -- ^ Run this job when "test-primops" label is set
+  | I386Backend  -- ^ Run this job when the "i386" label is set
+  deriving (Show, Ord, Eq)
+
+-- | Convert the state of the rule into a string that gitlab understand.
+ruleToCond :: OnOff -> Rule -> Cond
+ruleToCond On (ValidateOnly only_job_name vs) =
+    or_all
+    [ -- 1. Case when ONLY_JOBS is set
+      and_all [ varIsSet "ONLY_JOBS"
+              , Cond $ "$ONLY_JOBS =~ /.*\\b" ++ escape only_job_name ++ "(\\s|$).*/"
+              ]
+      -- 2. Case when ONLY_JOBS is null
+    , and_all [ varIsNull "ONLY_JOBS"
+              , case S.toList vs of
+                  [] -> _false
+                  cs -> or_all (map validateRuleString cs)
+              ]
+    ]
+  where
+    escape :: String -> String
+    escape = concatMap (\c -> if c == '+' then "\\+" else [c])
+ruleToCond Off (ValidateOnly {}) = true
+ruleToCond On  ReleaseOnly       = "RELEASE_JOB" `varEqString` "yes"
+ruleToCond Off ReleaseOnly       = "RELEASE_JOB" `varNeString` "yes"
+ruleToCond On  Nightly           = varIsSet "NIGHTLY"
+ruleToCond Off Nightly           = varIsNull "NIGHTLY"
+
+
+validateRuleString :: ValidateRule -> Cond
+validateRuleString FullCI       = or_all [ labelString "full-ci"
+                                         , labelString "marge_bot_batch_merge_job"
+                                         , branchStringExact "master"
+                                         , branchStringLike "ghc-[0-9]+\\.[0-9]+"
+                                         ]
+validateRuleString FastCI       = true
 
 validateRuleString LLVMBackend  = labelString "LLVM backend"
 validateRuleString JSBackend    = labelString "javascript"
@@ -724,6 +772,10 @@ validateRuleString IpeData      = labelString "IPE"
 validateRuleString TestPrimops  = labelString "test-primops"
 validateRuleString I386Backend  = labelString "i386"
 
+---------------------------------------------------------------------
+-- The Job type
+---------------------------------------------------------------------
+
 -- | A 'Job' is the description of a single job in a gitlab pipeline. The
 -- job contains all the information about how to do the build but can be further
 -- modified with information about when to run jobs, which variables to set for
@@ -747,15 +799,15 @@ data Job
 instance ToJSON Job where
   toJSON Job{..} = object
     [ "stage" A..= jobStage
-    -- Convoluted to avoid download artifacts from ghci job
-    -- https://docs.gitlab.com/ee/ci/yaml/#needsartifacts
+      -- Convoluted to avoid download artifacts from ghci job
+      -- https://docs.gitlab.com/ee/ci/yaml/#needsartifacts
     , "needs" A..= map (\j -> object [ "job" A..= j, "artifacts" A..= False ]) jobNeeds
     , "dependencies" A..= jobDependencies
     , "image" A..= jobDockerImage
     , "tags" A..= jobTags
     , "allow_failure" A..= jobAllowFailure
-    -- Joining up variables like this may well be the wrong thing to do but
-    -- at least it doesn't lose information silently by overriding.
+      -- Joining up variables like this may well be the wrong thing to do but
+      -- at least it doesn't lose information silently by overriding.
     , "variables" A..= fmap unwords jobVariables
     , "artifacts" A..= jobArtifacts
     , "cache" A..= jobCache
@@ -783,7 +835,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       = [ "bash .gitlab/ci.sh setup"
         , "bash .gitlab/ci.sh configure"
         , "bash .gitlab/ci.sh build_hadrian"
-        , "bash .gitlab/ci.sh test_hadrian" ]
+        , "bash .gitlab/ci.sh test_hadrian"
+        ]
       | otherwise
       = [ "find libraries -name config.sub -exec cp config.sub {} \\;" | Darwin == opsys ] ++
         [ "sudo chown ghc:ghc -R ." | Linux {} <- [opsys]] ++
@@ -803,7 +856,8 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       [ ".gitlab/ci.sh save_cache"
       , ".gitlab/ci.sh save_test_output"
       , ".gitlab/ci.sh clean"
-      , "cat ci_timings" ]
+      , "cat ci_timings"
+      ]
 
     jobFlavour = mkJobFlavour buildConfig
 
@@ -819,9 +873,11 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
       , maybe mempty ("CONFIGURE_WRAPPER" =:) (configureWrapper buildConfig)
       , maybe mempty ("CROSS_TARGET" =:) (crossTarget buildConfig)
       , case crossEmulator buildConfig of
-          NoEmulator       -> case crossTarget buildConfig of
-            Nothing -> mempty
-            Just _  -> "CROSS_EMULATOR" =: "NOT_SET" -- we need an emulator but it isn't set. Won't run the testsuite
+          NoEmulator
+            -- we need an emulator but it isn't set. Won't run the testsuite
+            | Just _ <- crossTarget buildConfig
+                           -> "CROSS_EMULATOR" =: "NOT_SET"
+            | otherwise    -> mempty
           Emulator s       -> "CROSS_EMULATOR" =: s
           NoEmulatorNeeded -> mempty
       , if withNuma buildConfig then "ENABLE_NUMA" =: "1" else mempty
@@ -901,8 +957,10 @@ setVariable k v j = j { jobVariables = MonoidalMap $ Map.insert k [v] $ unMonoid
 delVariable :: String -> Job -> Job
 delVariable k j = j { jobVariables = MonoidalMap $ Map.delete k $ unMonoidalMap $ jobVariables j }
 
+---------------------------------------------------------------------
 -- Building the standard jobs
---
+---------------------------------------------------------------------
+
 -- | Make a normal validate CI job
 validate :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 validate = job
@@ -919,15 +977,27 @@ releaseRule = setJobRule ReleaseOnly
 nightly :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 nightly arch opsys bc =
   let NamedJob n j = job arch opsys bc
-  in NamedJob { name = "nightly-" ++ n, jobInfo = nightlyRule . keepArtifacts "8 weeks" . highCompression $ j}
+  in NamedJob { name = "nightly-" ++ n
+              , jobInfo = nightlyRule
+                        . keepArtifacts "8 weeks"
+                        . highCompression $ j
+              }
 
 -- | Make a normal release CI job
 release :: Arch -> Opsys -> BuildConfig -> NamedJob Job
 release arch opsys bc =
   let NamedJob n j = job arch opsys (bc { buildFlavour = Release })
-  in NamedJob { name = "release-" ++ n, jobInfo = releaseRule . keepArtifacts "1 year" . ignorePerfFailures . useHashUnitIds . highCompression $ j}
+  in NamedJob { name = "release-" ++ n
+              , jobInfo = releaseRule
+                        . keepArtifacts "1 year"
+                        . ignorePerfFailures
+                        . useHashUnitIds
+                        . highCompression $ j
+              }
 
+---------------------------------------------------------------------
 -- Specific job modification functions
+---------------------------------------------------------------------
 
 -- | Mark a job as requiring a manual trigger.
 manual :: Job -> Job
@@ -984,6 +1054,10 @@ onlyRule t = modifyValidateJobs (onlyValidateJobRule t)
 disableValidate :: JobGroup Job -> JobGroup Job
 disableValidate = modifyValidateJobs (removeValidateJobRule FastCI . removeValidateJobRule FullCI)
 
+---------------------------------------------------------------------
+-- NamedJob
+---------------------------------------------------------------------
+
 data NamedJob a = NamedJob { name :: String, jobInfo :: a } deriving (Show, Functor)
 
 renameJob :: (String -> String) -> NamedJob a -> NamedJob a
@@ -994,14 +1068,18 @@ instance ToJSON a => ToJSON (NamedJob a) where
     [ "name" A..= name nj
     , "jobInfo" A..= jobInfo nj ]
 
-
---data NamedJobGroup a = NamedJobGroup { platform :: String, jg :: JobGroup a }
+---------------------------------------------------------------------
+-- JobGroup
+---------------------------------------------------------------------
 
 -- Jobs are grouped into either triples or pairs depending on whether the
 -- job is just validate and nightly, or also release.
-data JobGroup a = StandardTriple { v :: Maybe (NamedJob a)
-                                 , n :: Maybe (NamedJob a)
-                                 , r :: Maybe (NamedJob a) } deriving (Functor, Show)
+data JobGroup a
+  = StandardTriple { v :: Maybe (NamedJob a)
+                   , n :: Maybe (NamedJob a)
+                   , r :: Maybe (NamedJob a)
+                   }
+  deriving (Functor, Show)
 
 instance ToJSON a => ToJSON (JobGroup a) where
   toJSON StandardTriple{..} = object
@@ -1039,16 +1117,19 @@ flattenJobGroup (StandardTriple a b c) = map flattenNamedJob (catMaybes [a,b,c])
 flattenNamedJob :: NamedJob a -> (String, a)
 flattenNamedJob (NamedJob n i) = (n, i)
 
-
 -- | Specification for all the jobs we want to build.
 jobs :: Map String Job
-jobs = Map.fromList $ concatMap (flattenJobGroup) job_groups
+jobs = Map.fromList $ concatMap flattenJobGroup job_groups
+
+---------------------------------------------------------------------
+-- Job definitions
+---------------------------------------------------------------------
 
 debian_x86 :: [JobGroup Job]
 debian_x86 =
   [ -- Release configurations
-  -- We still build Deb9 bindists for now due to Ubuntu 18 and Linux Mint 19
-  -- not being at EOL until April 2023 and they still need tinfo5.
+    -- We still build Deb9 bindists for now due to Ubuntu 18 and Linux Mint 19
+    -- not being at EOL until April 2023 and they still need tinfo5.
     disableValidate (standardBuildsWithConfig Amd64 (Linux Debian9) (splitSectionsBroken vanilla))
   , disableValidate (standardBuilds Amd64 (Linux Debian10))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Debian10) dwarf)
@@ -1056,15 +1137,15 @@ debian_x86 =
   , disableValidate (standardBuilds Amd64 (Linux Debian12))
 
 
-  -- Validate only builds
+    -- Validate only builds
   , fastCI (validateBuilds Amd64 (Linux validate_debian) debug)
   , validateBuilds Amd64 (Linux validate_debian) nativeInt
   , validateBuilds Amd64 (Linux validate_debian) unreg
-   -- More work is needed to address TSAN failures: #22520
+    -- More work is needed to address TSAN failures: #22520
   , modifyNightlyJobs allowFailure (modifyValidateJobs (allowFailure . manual) tsan_jobs)
   , -- Nightly allowed to fail: #22343
     modifyNightlyJobs allowFailure (modifyValidateJobs manual (validateBuilds Amd64 (Linux validate_debian) noTntc))
-  -- Run the 'perf' profiling nightly job in the release config.
+    -- Run the 'perf' profiling nightly job in the release config.
   , perfProfilingJob Amd64 (Linux Debian12) releaseConfig
 
   , onlyRule LLVMBackend (validateBuilds Amd64 (Linux validate_debian) llvm)
@@ -1095,7 +1176,7 @@ debian_aarch64 =
   [
      disableValidate (standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla))
    , fastCI (standardBuildsWithConfig AArch64 (Linux Debian12) (splitSectionsBroken vanilla))
-   -- LLVM backend bootstrap
+     -- LLVM backend bootstrap
    , onlyRule LLVMBackend (validateBuilds AArch64 (Linux Debian12) llvm)
   ]
 
@@ -1120,11 +1201,10 @@ rhel_x86 =
 
 fedora_x86 :: [JobGroup Job]
 fedora_x86 =
-  [
-  -- Fedora33 job is always built with perf so there's one job in the normal
-  -- validate pipeline which is built with perf.
+  [ -- Fedora33 job is always built with perf so there's one job in the normal
+    -- validate pipeline which is built with perf.
     fastCI (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig)
-  -- This job is only for generating head.hackage docs
+    -- This job is only for generating head.hackage docs
   , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) dwarf)
   , disableValidate (standardBuilds Amd64 (Linux Fedora38))
@@ -1154,7 +1234,7 @@ alpine_x86 =
   [ -- Fully static build, in theory usable on any linux distribution.
     fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken static))
   , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt)))
-  -- Dynamically linked build, suitable for building your own static executables on alpine
+    -- Dynamically linked build, suitable for building your own static executables on alpine
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken vanilla))
   , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine320) (splitSectionsBroken vanilla))
   , allowFailureGroup (standardBuildsWithConfig I386 (Linux Alpine320) (splitSectionsBroken vanilla))
@@ -1173,16 +1253,16 @@ alpine_aarch64 = [
 
 cross_jobs :: [JobGroup Job]
 cross_jobs = [
-  -- x86 -> aarch64
+    -- x86 -> aarch64
     validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
 
-  -- x86_64 -> riscv
+    -- x86_64 -> riscv
   , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing))
 
-  -- Javascript
+    -- Javascript
   , addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11Js) javascriptConfig)
 
-  -- Wasm
+    -- Wasm
   , make_wasm_jobs wasm_build_config
   , modifyValidateJobs manual $
       make_wasm_jobs wasm_build_config {bignumBackend = Native}
@@ -1203,10 +1283,9 @@ cross_jobs = [
 
     wasm_build_config =
       (crossConfig "wasm32-wasi" NoEmulatorNeeded Nothing)
-        {
-          hostFullyStatic = True
-          , buildFlavour     = Release -- TODO: This needs to be validate but wasm backend doesn't pass yet
-          , textWithSIMDUTF = True
+        { hostFullyStatic = True
+        , buildFlavour    = Release -- TODO: This needs to be validate but wasm backend doesn't pass yet
+        , textWithSIMDUTF = True
         }
 
 job_groups :: [JobGroup Job]
@@ -1224,6 +1303,9 @@ job_groups =
   ++ cross_jobs
   ++ freebsd_jobs
 
+---------------------------------------------------------------------
+-- Platform mapping for GHCup metadata
+---------------------------------------------------------------------
 
 mkPlatform :: Arch -> Opsys -> String
 mkPlatform arch opsys = archName arch <> "-" <> opsysName opsys
@@ -1267,7 +1349,11 @@ platform_mapping = Map.map go combined_result
                 , "release-x86_64-windows-release"
                 ]
 
-    process sel = Map.fromListWith combine [ (uncurry mkPlatform (jobPlatform (jobInfo $ j)), j) | (sel -> Just j) <- job_groups  ]
+    process sel =
+      Map.fromListWith combine
+      [ (uncurry mkPlatform (jobPlatform (jobInfo j)), j)
+      | (sel -> Just j) <- job_groups
+      ]
 
     vs = process v
     ns = process n
@@ -1275,10 +1361,13 @@ platform_mapping = Map.map go combined_result
 
     all_platforms = Map.keysSet vs <> Map.keysSet ns <> Map.keysSet rs
 
-    combined_result = Map.fromList [ (p, StandardTriple { v = Map.lookup p vs
-                                                        , n = Map.lookup p ns
-                                                        , r = Map.lookup p rs })
-                                   | p <- S.toList all_platforms ]
+    combined_result =
+      Map.fromList
+      [ (p, StandardTriple { v = Map.lookup p vs
+                           , n = Map.lookup p ns
+                           , r = Map.lookup p rs })
+      | p <- S.toList all_platforms
+      ]
 
     combine a b
       | name a `elem` whitelist = a -- Explicitly selected
@@ -1293,6 +1382,9 @@ data BindistInfo = BindistInfo { bindistName :: String } deriving Show
 instance ToJSON BindistInfo where
   toJSON (BindistInfo n) = object [ "bindistName" A..= n ]
 
+---------------------------------------------------------------------
+-- Main entrypoint
+---------------------------------------------------------------------
 
 main :: IO ()
 main = do


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -659,6 +659,7 @@ rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _)
 rnFamEqn :: HsDocContext
          -> AssocTyFamInfo
          -> FamEqn GhcPs rhs
+         -> FreeKiTyVars     -- Implicit binders of the rhs payload
          -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
          -> RnM (FamEqn GhcRn rhs', FreeVars)
 rnFamEqn doc atfi
@@ -666,7 +667,7 @@ rnFamEqn doc atfi
             , feqn_bndrs  = outer_bndrs
             , feqn_pats   = pats
             , feqn_fixity = fixity
-            , feqn_rhs    = payload }) rn_payload
+            , feqn_rhs    = payload }) payload_kvs rn_payload
   = do { tycon' <- lookupFamInstName mb_cls tycon
 
          -- all_imp_vars represent the implicitly bound type variables. This is
@@ -697,7 +698,7 @@ rnFamEqn doc atfi
          --
          -- For associated type family instances, exclude the type variables
          -- bound by the instance head with filterInScopeM (#19649).
-       ; all_imp_vars <- filterInScopeM $ pat_kity_vars
+       ; all_imp_vars <- filterInScopeM $ (pat_kity_vars ++ payload_kvs)
 
        ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
     do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
@@ -788,7 +789,7 @@ rnFamEqn doc atfi
     --   type instance F a b c = Either a b
     --                   ^^^^^
     lhs_loc = case map lhsTypeArgSrcSpan pats of
-      []         -> panic "rnFamEqn.lhs_loc"
+      []         -> getLocA tycon
       [loc]      -> loc
       (loc:locs) -> loc `combineSrcSpans` last locs
 
@@ -847,8 +848,9 @@ rnTyFamInstEqn :: AssocTyFamInfo
                -> TyFamInstEqn GhcPs
                -> RnM (TyFamInstEqn GhcRn, FreeVars)
 rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon })
-  = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn
-
+  = rnFamEqn (TySynCtx tycon) atfi eqn
+       [{- No implicit vars on RHS of a type instance -}]
+       rnTySyn
 
 rnTyFamDefltDecl :: Name
                  -> TyFamDefltDecl GhcPs
@@ -859,9 +861,9 @@ rnDataFamInstDecl :: AssocTyFamInfo
                   -> DataFamInstDecl GhcPs
                   -> RnM (DataFamInstDecl GhcRn, FreeVars)
 rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
-                    eqn@(FamEqn { feqn_tycon = tycon })})
-  = do { (eqn', fvs) <-
-           rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn
+                    eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = defn })})
+  = do { let implicit_kvs = extractDataDefnKindVars defn
+       ; (eqn', fvs) <- rnFamEqn (TyDataCtx tycon) atfi eqn implicit_kvs rnDataDefn
        ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
 
 -- Renaming of the associated types in instances.


=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2212,7 +2212,7 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
     --           esp the bullet on nested forall types
   = do { kv_details <- newTauTvDetailsAtLevel hole_lvl
        ; kv_name    <- newMetaTyVarName (fsLit "k")
-       ; wc_details <- newTauTvDetailsAtLevel hole_lvl
+       ; wc_details <- mk_wc_details hole_lvl
        ; wc_name    <- newMetaTyVarName wc_nm
        ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details
              wc_kind = mkTyVarTy kv
@@ -2231,11 +2231,11 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
        ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }
   where
      -- See Note [Wildcard names]
-     wc_nm = case hole_mode of
-               HM_Sig      -> fsLit "w"
-               HM_FamPat   -> fsLit "_"
-               HM_VTA      -> fsLit "w"
-               HM_TyAppPat -> fsLit "_"
+     (wc_nm, mk_wc_details) = case hole_mode of
+               HM_Sig      -> (fsLit "w", newTauTvDetailsAtLevel)
+               HM_FamPat   -> (fsLit "_", newWildCardTvDetailsAtLevel)
+               HM_VTA      -> (fsLit "w", newTauTvDetailsAtLevel)
+               HM_TyAppPat -> (fsLit "_", newTauTvDetailsAtLevel)
 
      emit_holes = case hole_mode of
                      HM_Sig     -> True


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3141,7 +3141,7 @@ tcDataDefn err_ctxt roles_info tc_name
                                                -- via inferInitialKinds
                        , dd_cons = cons
                        , dd_derivs = derivs })
-  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->
+  = bindTyClTyVars tc_name $ \ tc_bndrs tc_res_kind ->
        -- The TyCon tyvars must scope over
        --    - the stupid theta (dd_ctxt)
        --    - for H98 constructors only, the ConDecl
@@ -3152,18 +3152,18 @@ tcDataDefn err_ctxt roles_info tc_name
        ; tcg_env <- getGblEnv
        ; let hsc_src = tcg_src tcg_env
        ; unless (mk_permissive_kind hsc_src cons) $
-         checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind
+         checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) tc_res_kind
 
-       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
+       ; tc_stupid_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
                             tcHsContext ctxt
 
        -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
        -- Example: (typecheck/should_fail/T17567StupidTheta)
        --   data (forall a. a b ~ a c) => T b c
        -- The kind of 'a' is unconstrained.
-       ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta
+       ; dvs <- candidateQTyVarsOfTypes tc_stupid_theta
        ; let err_ctx tidy_env
-               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta
+               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env tc_stupid_theta
                     ; return (tidy_env2, UninfTyCtx_DataContext theta) }
        ; doNotQuantifyTyVars dvs err_ctx
 
@@ -3177,12 +3177,12 @@ tcDataDefn err_ctxt roles_info tc_name
 
        ; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $
          runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs ->
-           do { stupid_theta   <- zonkTcTypesToTypesX stupid_tc_theta
-              ; res_kind       <- zonkTcTypeToTypeX   res_kind
+           do { stupid_theta   <- zonkTcTypesToTypesX tc_stupid_theta
+              ; res_kind       <- zonkTcTypeToTypeX   tc_res_kind
               ; return (bndrs, stupid_theta, res_kind) }
 
        ; tycon <- fixM $ \ rec_tycon -> do
-             { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
+             { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs tc_res_kind cons
              ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons
              ; tc_rep_nm <- newTyConRepName tc_name
 
@@ -3360,24 +3360,52 @@ So, we use bindOuterFamEqnTKBndrs (which does not create an implication for
 the telescope), and generalise over /all/ the variables in the LHS,
 without treating the explicitly-quantified ones specially. Wrinkles:
 
- - When generalising, include the explicit user-specified forall'd
+(GT1) When generalising, include the explicit user-specified forall'd
    variables, so that we get an error from Validity.checkFamPatBinders
    if a forall'd variable is not bound on the LHS
 
- - We still want to complain about a bad telescope among the user-specified
+(GT2) We still want to complain about a bad telescope among the user-specified
    variables.  So in checkFamTelescope we emit an implication constraint
    quantifying only over them, purely so that we get a good telescope error.
 
-  - Note that, unlike a type signature like
+(GT3) Note that, unlike a type signature like
        f :: forall (a::k). blah
     we do /not/ care about the Inferred/Specified designation or order for
     the final quantified tyvars.  Type-family instances are not invoked
     directly in Haskell source code, so visible type application etc plays
     no role.
 
-See also Note [Re-quantify type variables in rules] in
-GHC.Tc.Gen.Rule, which explains a /very/ similar design when
-generalising over the type of a rewrite rule.
+(GT4) Consider #25647 (with UnliftedNewtypes)
+         type N :: forall r. (TYPE r -> TYPE r) -> TYPE r
+         newtype N f where { MkN :: ff (N ff) -> N ff }
+    When kind-checking the type signature for MkN we'll start wtih
+           ff :: TYPE kappa -> TYPE kappa
+           MkN :: ff (N @kappa) ff -> N @kappa ff
+    Then we generalise /and default the RuntimeRep variable kappa/
+    (via `kindGeneralizeAll` in `tcConDecl`), thus kappa := LiftedRep
+
+    But now the newtype looks like a GADT and we get an error
+         A newtype must not be a GADT
+
+    This seems OK.  We are just following the rules.
+
+    But this variant (the original report in #25647)
+       data family Fix2 :: (k -> Type) -> k
+       newtype instance Fix2 f where { In2 :: f (Fix2 f) -> Fix2 f }
+    At the `newtype instance`, we first
+       1. Find the kind of the newtype instance in `tcDataFamInstHeader`
+       2. Typecheck the newtype definitition itself in `tcConDecl`
+    In step 1 we do /not/ want to get
+       newtype instance forall r .  Fix2 (f :: TYPE r -> TYPE r) :: TYPE r where
+    If we do, we'll get that same "newtype must not be GADT" error as for N above.
+    Rather, we want to default the RuntimeRep variable r := LiftedRep. Hence
+    the use of `DefaultNonStandardTyVars` in `tcDataFamInstHeader`.  The key thing
+    is that we must make the /same/ choice here as we do in kind-checking the data
+    constructor's type.
+
+See also Note [Re-quantify type variables in rules] in GHC.Tc.Gen.Rule, which
+explains a /very/ similar design when generalising over the type of a rewrite
+rule.
 
 -}
 
@@ -3423,7 +3451,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
 
        -- See Note [Generalising in tcTyFamInstEqnGuts]
        ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty
-       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
+       ; qtvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs
        ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
              -- This scopedSort is important: the qtvs may be /interleaved/ with
              -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]
@@ -3753,23 +3781,30 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
 
        ; return (NE.singleton dc) }
 
-tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
-  -- NB: don't use res_kind here, as it's ill-scoped. Instead,
+tcConDecl new_or_data dd_info rep_tycon tc_bndrs _tc_res_kind tag_map
+  -- NB: don't use _tc_res_kind here, as it's ill-scoped. Instead,
   -- we get the res_kind by typechecking the result type.
           (ConDeclGADT { con_names = names
                        , con_bndrs = L _ outer_hs_bndrs
                        , con_mb_cxt = cxt, con_g_args = hs_args
                        , con_res_ty = hs_res_ty })
   = addErrCtxt (DataConDefCtxt names) $
-    do { traceTc "tcConDecl 1 gadt" (ppr names)
+    do { traceTc "tcConDecl 1 gadt" (ppr names $$ ppr _tc_res_kind)
        ; let L _ name :| _ = names
        ; skol_info <- mkSkolemInfo (DataConSkol name)
-       ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
+       ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts, res_kind)))
            <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $
               tcOuterTKBndrs skol_info outer_hs_bndrs       $
               do { ctxt <- tcHsContext cxt
+
                  ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
-                         -- See Note [GADT return kinds]
+                              -- See Note [GADT return kinds]
+
+                   -- See Note [Datatype return kinds]
+                 ; let exp_kind = getArgExpKind new_or_data res_kind
+                 ; btys <- tcConGADTArgs exp_kind hs_args
+
+                 ; traceTc "tcConDecl 1a gadt" (ppr res_ty <+> dcolon <+> ppr res_kind)
 
                  -- For data instances (only), ensure that the return type,
                  -- res_ty, is a substitution instance of the header.
@@ -3784,13 +3819,9 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
                              addErrCtxt (DataConResTyCtxt names) $
                              unifyType Nothing res_ty head_shape }
 
-                   -- See Note [Datatype return kinds]
-                 ; let exp_kind = getArgExpKind new_or_data res_kind
-                 ; btys <- tcConGADTArgs exp_kind hs_args
-
                  ; let (arg_tys, stricts) = unzip btys
                  ; field_lbls <- lookupConstructorFields name
-                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts, res_kind)
                  }
 
        ; outer_bndrs <- scopedSortOuter outer_bndrs
@@ -3801,7 +3832,10 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
                      tcMkPhiTy ctxt                  $
                      tcMkScaledFunTys arg_tys        $
                      res_ty)
-       ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)
+       ; traceTc "tcConDecl:GADT" (vcat [ text "names:" <+> ppr names
+                                        , text "tkvs:" <+> ppr tkvs
+                                        , text "res_ty:" <+> ppr res_ty
+                                        , text "res_kind:" <+> ppr res_kind ])
        ; reportUnsolvedEqualities skol_info tkvs tclvl wanted
 
        ; let tvbndrs =  mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -790,10 +790,10 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
               , text "eta_tcbs" <+> ppr eta_tcbs ]
        ; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) ->
            do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $
-                  -- For H98 decls, the tyvars scope
-                  -- over the data constructors
-                  tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind
-                      hs_cons
+                             -- tcExtendTyVarEnv: for H98 decls, the tyvars
+                             -- scope over the data constructors
+                             tcConDecls (DDataInstance orig_res_ty) rec_rep_tc
+                                        tc_ty_binders tc_res_kind hs_cons
 
               ; rep_tc_name <- newFamInstTyConName lfam_name pats
               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]
@@ -943,11 +943,6 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
                   -- with its parent class
                   ; addConsistencyConstraints mb_clsinfo lhs_ty
 
-                  -- Add constraints from the data constructors
-                  -- Fix #25611
-                  -- See DESIGN CHOICE in Note [Kind inference for data family instances]
-                  ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons
-
                   -- Check that the result kind of the TyCon applied to its args
                   -- is compatible with the explicit signature (or Type, if there
                   -- is none)
@@ -956,6 +951,11 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
                   ; res_kind <- tc_kind_sig m_ksig
                   ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
 
+                  -- Add constraints from the data constructors
+                  -- Fix #25611
+                  -- See DESIGN CHOICE in Note [Kind inference for data family instances]
+                  ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons
+
                   ; traceTc "tcDataFamInstHeader" $
                     vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]
                   ; return ( stupid_theta
@@ -975,7 +975,10 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
 
        -- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
        ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty
-       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
+       ; qtvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs
+                 -- DefaultNonStandardTyVars: see (GT4) in
+                 -- GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
+
        ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
              -- This scopedSort is important: the qtvs may be /interleaved/ with
              -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]
@@ -999,7 +1002,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
 
        -- Split up the LHS type to get the type patterns
        -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]
-       ; let pats      = unravelFamInstPats lhs_ty
+       ; let pats = unravelFamInstPats lhs_ty
 
        ; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) }
   where


=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -34,7 +34,8 @@ module GHC.Tc.Utils.TcMType (
 
   newMultiplicityVar,
   readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
-  newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName,
+  newWildCardTvDetailsAtLevel, newTauTvDetailsAtLevel,
+  newMetaDetails, newMetaTyVarName,
   isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
 
   --------------------------------
@@ -692,6 +693,16 @@ the thinking.
 *                                                                      *
 ********************************************************************* -}
 
+{- Note [WildCardTv]
+~~~~~~~~~~~~~~~~~
+A WildCardTv behaves like a TauTv, except that it can not be defaulted.
+
+It is used for a anonymous wildcard in a type signature, e.g.
+  f :: _ -> Int
+  f = ...
+
+-}
+
 {- Note [TyVarTv]
 ~~~~~~~~~~~~~~~~~
 A TyVarTv can unify with type *variables* only, including other TyVarTvs and
@@ -740,6 +751,7 @@ metaInfoToTyVarName :: MetaInfo -> FastString
 metaInfoToTyVarName  meta_info =
   case meta_info of
        TauTv          -> fsLit "t"
+       WildCardTv     -> fsLit "_"
        TyVarTv        -> fsLit "a"
        RuntimeUnkTv   -> fsLit "r"
        CycleBreakerTv -> fsLit "b"
@@ -853,6 +865,13 @@ newTauTvDetailsAtLevel tclvl
                         , mtv_ref   = ref
                         , mtv_tclvl = tclvl }) }
 
+newWildCardTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails
+newWildCardTvDetailsAtLevel tclvl
+  = do { ref <- newMutVar Flexi
+       ; return (MetaTv { mtv_info  = WildCardTv
+                        , mtv_ref   = ref
+                        , mtv_tclvl = tclvl }) }
+
 newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails
 newConcreteTvDetailsAtLevel conc_orig tclvl
   = do { ref <- newMutVar Flexi
@@ -1841,7 +1860,10 @@ defaultTyVar :: DefaultingStrategy
              -> TcTyVar    -- If it's a MetaTyVar then it is unbound
              -> TcM Bool   -- True <=> defaulted away altogether
 defaultTyVar def_strat tv
-  | not (isMetaTyVar tv)
+  | not (isMetaTyVar tv )
+  || isWildCardMetaTyVar tv
+    -- do not default WildcardTvs, wildcardTvs are are only meant to be unified
+    -- or be on its own but never defaulted.
   || isTyVarTyVar tv
     -- Do not default TyVarTvs. Doing so would violate the invariants
     -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.


=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -51,7 +51,8 @@ module GHC.Tc.Utils.TcType (
   TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk,
   MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo,
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
-  tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,
+  isWildCardMetaTyVar, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,
+  isTyConableTyVar,
   ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,
   isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe,
   ConcreteTyVars, noConcreteTyVars,
@@ -640,7 +641,8 @@ data MetaInfo
    = TauTv         -- ^ This MetaTv is an ordinary unification variable
                    -- A TauTv is always filled in with a tau-type, which
                    -- never contains any ForAlls.
-
+   | WildCardTv    -- ^ A variant of TauTv, except that it should not be
+                   -- defaulted.
    | TyVarTv       -- ^ A variant of TauTv, except that it should not be
                    --   unified with a type, only with a type variable
                    -- See Note [TyVarTv] in GHC.Tc.Utils.TcMType
@@ -670,6 +672,8 @@ instance Outputable MetaInfo where
   ppr RuntimeUnkTv    = text "rutv"
   ppr CycleBreakerTv  = text "cbv"
   ppr (ConcreteTv {}) = text "conc"
+  ppr (WildCardTv)    = text "wc"
+
 
 -- | What caused us to create a 'ConcreteTv' metavariable?
 -- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.
@@ -1179,7 +1183,7 @@ isImmutableTyVar :: TyVar -> Bool
 isImmutableTyVar tv = isSkolemTyVar tv
 
 isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
-  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool
+  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar, isWildCardMetaTyVar :: TcTyVar -> Bool
 
 isTyConableTyVar tv
         -- True of a meta-type variable that can be filled in
@@ -1220,6 +1224,13 @@ isMetaTyVar tv
         _         -> False
   | otherwise = False
 
+isWildCardMetaTyVar tv
+  | isTyVar tv -- See Note [Coercion variables in free variable lists]
+  = case tcTyVarDetails tv of
+        MetaTv { mtv_info = WildCardTv } -> True
+        _                                 -> False
+  | otherwise = False
+
 -- isAmbiguousTyVar is used only when reporting type errors
 -- It picks out variables that are unbound, namely meta
 -- type variables and the RuntimeUnk variables created by


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -2574,8 +2574,9 @@ lhsPriority tv
              CycleBreakerTv -> 0
              TyVarTv        -> 1
              ConcreteTv {}  -> 2
-             TauTv          -> 3
-             RuntimeUnkTv   -> 4
+             WildCardTv     -> 3
+             TauTv          -> 4
+             RuntimeUnkTv   -> 5
 
 {- Note [Unification preconditions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -809,9 +809,11 @@ data HsDataDefn pass   -- The payload of a data type defn
                        --       *and* for data family instances
   = -- | Declares a data type or newtype, giving its constructors
     -- @
-    --  data/newtype T a = <constrs>
-    --  data/newtype instance T [a] = <constrs>
+    --  data/newtype T a :: ksig = <constrs>
+    --  data/newtype instance T [a] :: ksig = <constrs>
     -- @
+    -- The HsDataDefn describes the (optional) kind signature and the <constrs>
+    -- but not the `data T a` or `newtype T [a]` headers
     HsDataDefn { dd_ext    :: XCHsDataDefn pass,
                  dd_ctxt   :: Maybe (LHsContext pass), -- ^ Context
                  dd_cType  :: Maybe (XRec pass CType),


=====================================
libraries/base/changelog.md
=====================================
@@ -10,6 +10,13 @@
   * `Data.List.NonEmpty` functions now have the same laziness as their `Data.List` counterparts (i.e. make them more strict than they currently are) ([CLC proposal #107](https://github.com/haskell/core-libraries-committee/issues/107))
   * `instance Functor NonEmpty` is now specified using `map` (rather than duplicating code). ([CLC proposal #300](https://github.com/haskell/core-libraries-committee/issues/300))
   * The `Data.Enum.enumerate` function was introduced ([CLC #306](https://github.com/haskell/core-libraries-committee/issues/306))
+  * Worker threads used by various `base` facilities are now labelled with descriptive thread labels ([CLC proposal #305](https://github.com/haskell/core-libraries-committee/issues/305), [GHC #25452](https://gitlab.haskell.org/ghc/ghc/-/issues/25452)). Specifically, these include:
+    * `Control.Concurrent.threadWaitRead`
+    * `Control.Concurrent.threadWaitWrite`
+    * `Control.Concurrent.threadWaitReadSTM`
+    * `Control.Concurrent.threadWaitWriteSTM`
+    * `System.Timeout.timeout`
+    * `GHC.Conc.Signal.runHandlers`
 
 ## 4.21.0.0 *TBA*
   * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55))


=====================================
libraries/base/src/Control/Concurrent.hs
=====================================
@@ -265,7 +265,7 @@ threadWaitRead fd
   -- fdReady does the right thing, but we have to call it in a
   -- separate thread, otherwise threadWaitRead won't be interruptible,
   -- and this only works with -threaded.
-  | threaded  = withThread (waitFd fd False)
+  | threaded  = withThread "threadWaitRead worker" (waitFd fd False)
   | otherwise = case fd of
                   0 -> do _ <- hWaitForInput stdin (-1)
                           return ()
@@ -286,7 +286,7 @@ threadWaitRead fd
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite fd
 #if defined(mingw32_HOST_OS)
-  | threaded  = withThread (waitFd fd True)
+  | threaded  = withThread "threadWaitWrite worker" (waitFd fd True)
   | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"
 #else
   = Conc.threadWaitWrite fd
@@ -302,8 +302,11 @@ threadWaitReadSTM :: Fd -> IO (STM (), IO ())
 threadWaitReadSTM fd
 #if defined(mingw32_HOST_OS)
   | threaded = do v <- newTVarIO Nothing
-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd False)
-                                             atomically (writeTVar v $ Just result)
+                  mask_ $ void $ forkIO $ do
+                    tid <- myThreadId
+                    labelThread tid "threadWaitReadSTM worker"
+                    result <- try (waitFd fd False)
+                    atomically (writeTVar v $ Just result)
                   let waitAction = do result <- readTVar v
                                       case result of
                                         Nothing         -> retry
@@ -326,8 +329,11 @@ threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
 threadWaitWriteSTM fd
 #if defined(mingw32_HOST_OS)
   | threaded = do v <- newTVarIO Nothing
-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd True)
-                                             atomically (writeTVar v $ Just result)
+                  mask_ $ void $ forkIO $ do
+                    tid <- myThreadId
+                    labelThread tid "threadWaitWriteSTM worker"
+                    result <- try (waitFd fd True)
+                    atomically (writeTVar v $ Just result)
                   let waitAction = do result <- readTVar v
                                       case result of
                                         Nothing         -> retry
@@ -343,10 +349,14 @@ threadWaitWriteSTM fd
 #if defined(mingw32_HOST_OS)
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
-withThread :: IO a -> IO a
-withThread io = do
+withThread :: String -> IO a -> IO a
+withThread label io = do
   m <- newEmptyMVar
-  _ <- mask_ $ forkIO $ try io >>= putMVar m
+  _ <- mask_ $ forkIO $ do
+    tid <- myThreadId
+    labelThread tid label
+    result <- try io
+    putMVar m result
   x <- takeMVar m
   case x of
     Right a -> return a


=====================================
libraries/base/src/System/Timeout.hs
=====================================
@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 
 -------------------------------------------------------------------------------
 -- |
@@ -29,6 +29,7 @@ import GHC.Internal.Control.Exception   (Exception(..), handleJust, bracket,
                             asyncExceptionToException,
                             asyncExceptionFromException)
 import GHC.Internal.Data.Unique         (Unique, newUnique)
+import GHC.Conc (labelThread)
 import Prelude
 
 -- $setup
@@ -119,7 +120,9 @@ timeout n f
         let handleTimeout = do
                 v <- isEmptyMVar lock
                 when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
-                    v2 <- tryPutMVar lock =<< myThreadId
+                    tid <- myThreadId
+                    labelThread tid "timeout worker"
+                    v2 <- tryPutMVar lock tid
                     when v2 $ throwTo pid ex
             cleanupTimeout key = uninterruptibleMask_ $ do
                 v <- tryPutMVar lock undefined
@@ -136,7 +139,9 @@ timeout n f
         ex  <- fmap Timeout newUnique
         handleJust (\e -> if e == ex then Just () else Nothing)
                    (\_ -> return Nothing)
-                   (bracket (forkIOWithUnmask $ \unmask ->
+                   (bracket (forkIOWithUnmask $ \unmask -> do
+                                 tid <- myThreadId
+                                 labelThread tid "timeout worker"
                                  unmask $ threadDelay n >> throwTo pid ex)
                             (uninterruptibleMask_ . killThread)
                             (\_ -> fmap Just f))


=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
=====================================
@@ -19,7 +19,7 @@ import GHC.Internal.Foreign.Ptr (Ptr, castPtr)
 import GHC.Internal.Foreign.Marshal.Alloc (finalizerFree)
 import GHC.Internal.Arr (inRange)
 import GHC.Internal.Base
-import GHC.Internal.Conc.Sync (forkIO)
+import GHC.Internal.Conc.Sync (myThreadId, labelThread, forkIO)
 import GHC.Internal.IO (mask_, unsafePerformIO)
 import GHC.Internal.IOArray (IOArray, boundsIOArray, newIOArray,
                     unsafeReadIOArray, unsafeWriteIOArray)
@@ -69,7 +69,10 @@ runHandlers p_info sig = do
       else do handler <- unsafeReadIOArray arr int
               case handler of
                 Nothing -> return ()
-                Just (f,_)  -> do _ <- forkIO (f p_info)
+                Just (f,_)  -> do _ <- forkIO $ do
+                                    tid <- myThreadId
+                                    labelThread tid "signal handler"
+                                    f p_info
                                   return ()
 
 -- It is our responsibility to free the memory buffer, so we create a


=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
=====================================
@@ -53,7 +53,10 @@ start_console_handler :: Word32 -> IO ()
 start_console_handler r =
   case toWin32ConsoleEvent r of
     Just x  -> withMVar win32ConsoleHandler $ \handler -> do
-                 _ <- forkIO (handler x)
+                 _ <- forkIO $ do
+                     tid <- myThreadId
+                     labelThread tid "console event handler"
+                     handler x
                  return ()
     Nothing -> return ()
 


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -226,7 +226,10 @@ sandboxIO opts io = do
     let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
     if useSandboxThread opts
        then do
-         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
+         tid <- forkIO $ do
+           tid <- myThreadId
+           labelThread tid "GHCi sandbox"
+           unsafeUnmask runIt >>= putMVar statusMVar
                                 -- empty: can't block
          redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
        else


=====================================
testsuite/tests/indexed-types/should_compile/T11450a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T11450a where
+
+class C x where
+  type T x
+
+instance C (Either a b) where
+  type T (Either _ b) = b -> b


=====================================
testsuite/tests/indexed-types/should_compile/T25611d.hs
=====================================
@@ -20,7 +20,7 @@ data instance T p q where
       MkkV :: forall l. l Int# -> T l Int#
 
 type N :: TYPE r -> TYPE r
-newtype N a = MkN a
+newtype N (a::TYPE r) = MkN a
 
 f :: Int# -> N Int#
 f x = MkN x
@@ -29,7 +29,7 @@ g :: Int -> N Int
 g x = MkN x
 
 data family D :: Type -> k -> k
-newtype instance D Int a = MkD a
+newtype instance D Int (a::TYPE r) = MkD a
 
 f1 :: Int# -> D Int Int#
 f1 x = MkD x


=====================================
testsuite/tests/indexed-types/should_compile/all.T
=====================================
@@ -315,3 +315,4 @@ test('T25611a', normal, compile, [''])
 test('T25611b', normal, compile, [''])
 test('T25611c', normal, compile, [''])
 test('T25611d', normal, compile, [''])
+test('T11450a', normal, compile, [''])


=====================================
testsuite/tests/indexed-types/should_fail/T9357.stderr
=====================================
@@ -1,4 +1,4 @@
 T9357.hs:12:15: error: [GHC-91510]
-    • Illegal polymorphic type: forall (a :: TYPE t). a -> a
+     Illegal polymorphic type: forall a. a -> a
     • In the type family instance declaration for ‘F’
 


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -10619,7 +10619,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11736,7 +11736,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12349,7 +12349,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13204,7 +13204,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -13664,7 +13664,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -14770,7 +14770,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -15385,7 +15385,7 @@ instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.JS.Prim.JSException -- Defined in ‘GHC.Internal.JS.Prim’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.JS.Prim.WouldBlockException -- Defined in ‘GHC.Internal.JS.Prim’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -16235,7 +16235,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -10881,7 +10881,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11992,7 +11992,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12608,7 +12608,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13476,7 +13476,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -10619,7 +10619,7 @@ module System.Posix.Types where
 
 
 module System.Timeout where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Timeout :: *
   newtype Timeout = ...
   timeout :: forall a. GHC.Internal.Types.Int -> GHC.Internal.Types.IO a -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe a)
@@ -11736,7 +11736,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Classes.Eq (GHC.Int
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Classes.Eq GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Classes.Eq GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance forall a. GHC.Internal.Classes.Ord a => GHC.Internal.Classes.Ord (GHC.Internal.Base.NonEmpty a) -- Defined in ‘GHC.Internal.Base’
@@ -12349,7 +12349,7 @@ instance GHC.Internal.Exception.Type.Exception GHC.Internal.Control.Exception.Ba
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.Data.Dynamic.Dynamic -- Defined in ‘GHC.Internal.Data.Dynamic’
 instance [safe] GHC.Internal.Exception.Type.Exception ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common.FileLockingNotSupported -- Defined in ‘ghc-internal-9.1300.0:GHC.Internal.IO.Handle.Lock.Common’
 instance GHC.Internal.Exception.Type.Exception GHC.Internal.IOPort.IOPortException -- Defined in ‘GHC.Internal.IOPort’
-instance [safe] GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Exception.Type.Exception System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance forall a k (b :: k). GHC.Internal.Float.Floating a => GHC.Internal.Float.Floating (GHC.Internal.Data.Functor.Const.Const a b) -- Defined in ‘GHC.Internal.Data.Functor.Const’
 instance forall a. GHC.Internal.Float.RealFloat a => GHC.Internal.Float.Floating (Data.Complex.Complex a) -- Defined in ‘Data.Complex’
 instance forall k1 k2 (f :: k1 -> *) (g :: k2 -> k1) (a :: k2). GHC.Internal.Float.Floating (f (g a)) => GHC.Internal.Float.Floating (Data.Functor.Compose.Compose f g a) -- Defined in ‘Data.Functor.Compose’
@@ -13204,7 +13204,7 @@ instance forall (c :: GHC.Internal.Types.Char). GHC.Internal.Show.Show (GHC.Inte
 instance forall (s :: GHC.Internal.Types.Symbol). GHC.Internal.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeChar -- Defined in ‘GHC.Internal.TypeLits’
 instance GHC.Internal.Show.Show GHC.Internal.TypeLits.SomeSymbol -- Defined in ‘GHC.Internal.TypeLits’
-instance [safe] GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
+instance GHC.Internal.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Lexeme -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance GHC.Internal.Show.Show GHC.Internal.Text.Read.Lex.Number -- Defined in ‘GHC.Internal.Text.Read.Lex’
 instance [safe] forall a b. GHC.Internal.Show.Show (a -> b) -- Defined in ‘Text.Show.Functions’


=====================================
testsuite/tests/rename/should_fail/T23512a.stderr
=====================================
@@ -1,6 +1,3 @@
-
 T23512a.hs:6:31: error: [GHC-76037] Not in scope: type variable ‘j’
 
 T23512a.hs:6:36: error: [GHC-76037] Not in scope: type variable ‘j’
-
-T23512a.hs:9:20: error: [GHC-76037] Not in scope: type variable ‘k’


=====================================
testsuite/tests/typecheck/should_compile/T25647_fail.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds, UnliftedNewtypes, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647_fail where
+
+import GHC.Exts
+import Data.Kind
+
+-- Rejected because in the type signature for In2 we default
+-- the runtime-rep variable to LiftedRep, and that makes In2
+-- into a GADT
+newtype Fix2 f :: TYPE r where
+   In2 :: forall ff. ff (Fix2 ff) -> Fix2 ff
+
+-- Rejected for the same reason
+type Fix4a :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix4a f where
+  In4a :: ff (Fix4a ff) -> Fix4a ff
+
+data family Dix6 :: (k -> TYPE 'IntRep) -> k
+newtype instance Dix6 f where
+  DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff


=====================================
testsuite/tests/typecheck/should_compile/T25647_fail.stderr
=====================================
@@ -0,0 +1,23 @@
+T25647_fail.hs:12:4: [GHC-89498]
+     A newtype must not be a GADT
+      In2 :: forall (ff :: * -> *).
+             ff (Fix2 @LiftedRep ff) -> Fix2 @LiftedRep ff
+     In the definition of data constructor ‘In2’
+      In the newtype declaration for ‘Fix2’
+
+T25647_fail.hs:17:3: [GHC-89498]
+     A newtype must not be a GADT
+      In4a :: forall (ff :: * -> *).
+              ff (Fix4a @LiftedRep ff) -> Fix4a @LiftedRep ff
+     In the definition of data constructor ‘In4a’
+      In the newtype declaration for ‘Fix4a’
+
+T25647_fail.hs:21:3: [GHC-18872]
+     Couldn't match a lifted type with an unlifted type
+      When matching types
+        ff :: TYPE IntRep -> TYPE IntRep
+        f0 :: * -> TYPE IntRep
+      Expected: Dix6 f0
+        Actual: Dix6 ff
+     In the result type of data constructor ‘DIn6’
+      In the newtype family instance declaration for ‘Dix6’
\ No newline at end of file


=====================================
testsuite/tests/typecheck/should_compile/T25647a.hs
=====================================
@@ -0,0 +1,92 @@
+{-# LANGUAGE DataKinds, UnliftedNewtypes, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647a where
+
+import GHC.Exts
+import Data.Kind
+
+-------------------- Plain newtypes -----------------
+
+-- A plain newtype, H98
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1a f = In1a (f (Fix1a f))
+
+-- A plain newtype, GADT syntax
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1b f where
+    In1b :: forall ff. ff (Fix1b ff) -> Fix1b ff
+
+-- A plain newtype, GADT syntax, with a return kind signature,
+-- and runtime-rep quantification in the data constructor
+-- Should infer Fix2 :: forall r k. (k -> TYPE r) -> TYPE r
+newtype Fix2 f :: TYPE r where
+   In2 :: forall r (ff :: TYPE r -> TYPE r). ff (Fix2 ff) -> Fix2 ff
+
+-- Plain newtype, H98 syntax, standalone kind signature
+-- Should get In3 :: forall r (f :: TYPE r -> TYPE r). Fix3 @r f -> Fix3 @r f
+type Fix3 :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix3 f = In3 (f (Fix3 f))
+
+-- Plain newtype, H98 syntax, standalone kind signature
+-- Should get In4 :: forall r k (f :: k -> TYPE r). Fix4 @r @k f -> Fix4 @r @k f
+type Fix4 :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix4 f where
+  In4 :: forall rr (ff :: TYPE rr -> TYPE rr).
+         ff (Fix4 ff) -> Fix4 @rr ff
+
+-------------------- Data families with newtype instance -----------------
+
+-- data instance in GADT sytntax
+data family Dix1 :: (k -> Type) -> k
+data instance Dix1 f where
+  DIn1 :: forall ff. ff (Dix1 ff) -> Dix1 ff
+
+-- newtype instance in GADT syntax
+data family Dix2 :: (k -> Type) -> k
+newtype instance Dix2 f where
+  DIn2 :: forall ff. ff (Dix2 ff) -> Dix2 ff
+
+data family Dix2a :: (k -> Type) -> k
+newtype instance Dix2a f :: Type where
+  DIn2a :: forall ff. ff (Dix2a ff) -> Dix2a ff
+
+-- newtype instance in H98 syntax
+data family Dix3 :: (k -> Type) -> k
+newtype instance Dix3 f = DIn3 (f (Dix3 f))
+
+-- newtype instance in GADT syntax
+-- The newtype instance defaults to LiftedRep
+data family Dix4 :: (k -> TYPE r) -> k
+newtype instance Dix4 f where
+  DIn4 :: forall ff. ff (Dix4 ff) -> Dix4 ff
+
+-- newtype instance in H98 syntax
+data family Dix5 :: (k -> TYPE r) -> k
+newtype instance Dix5 f = DIn5 (f (Dix5 f))
+
+-- -- newtype instance that is not TYPE 'LiftedRep
+-- data family Dix6 :: (k -> TYPE 'IntRep) -> k
+-- newtype instance Dix6 f where
+--   DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff
+
+data family Dix7 :: (k -> TYPE 'IntRep) -> k
+newtype instance Dix7 f = DIn7 (f (Dix7 f))
+
+
+
+-- anonymous wildcards
+type Dix8 :: RuntimeRep -> Type
+data family Dix8 r
+newtype instance Dix8 _ = Dix8 Int
+
+dix8 :: Dix8 FloatRep -> Int
+dix8 (Dix8 x) = x
+
+
+-- named wildcards
+type Dix9 :: RuntimeRep -> Type
+data family Dix9 r
+newtype instance Dix9 _r = Dix9 Int
+
+dix9 :: Dix9 FloatRep -> Int
+dix9 (Dix9 x) = x


=====================================
testsuite/tests/typecheck/should_compile/T25647b.hs
=====================================
@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647b where
+
+import GHC.Exts
+import Data.Kind
+
+---------------------------
+-- without UnliftedNewtypes
+---------------------------
+
+-------------------- Plain newtypes -----------------
+
+-- A plain newtype, H98
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1a f = In1a (f (Fix1a f))
+
+-- A plain newtype, GADT syntax
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1b f where
+    In1b :: forall ff. ff (Fix1b ff) -> Fix1b ff
+
+-- A plain newtype, GADT syntax, with a return kind signature,
+-- and runtime-rep quantification in the data constructor
+-- Should infer Fix2 :: (Type -> Type) -> Type
+newtype Fix2 f where
+   In2 :: forall (ff :: Type -> Type). ff (Fix2 ff) -> Fix2 ff
+
+-- Plain newtype, H98 syntax, standalone kind signature
+type Fix3 :: (Type -> Type) -> Type
+newtype Fix3 f = In3 (f (Fix3 f))
+
+-- Plain newtype, H98 syntax, standalone kind signature
+type Fix4 :: (Type -> Type) -> Type
+newtype Fix4 f where
+  In4 :: forall (ff :: Type -> Type).
+         ff (Fix4 ff) -> Fix4 ff
+
+-------------------- Data families with newtype instance -----------------
+
+-- data instance in GADT sytntax
+data family Dix1 :: (k -> Type) -> k
+data instance Dix1 f where
+  DIn1 :: forall ff. ff (Dix1 ff) -> Dix1 ff
+
+-- newtype instance in GADT syntax
+data family Dix2 :: (k -> Type) -> k
+newtype instance Dix2 f where
+  DIn2 :: forall ff. ff (Dix2 ff) -> Dix2 ff
+
+data family Dix2a :: (k -> Type) -> k
+newtype instance Dix2a f :: Type where
+  DIn2a :: forall ff. ff (Dix2a ff) -> Dix2a ff
+
+-- newtype instance in H98 syntax
+data family Dix3 :: (k -> Type) -> k
+newtype instance Dix3 f = DIn3 (f (Dix3 f))
+
+-- newtype instance in H98 syntax
+data family Dix5 :: (k -> TYPE r) -> k
+newtype instance Dix5 f = DIn5 (f (Dix5 f))
+
+-- data family Dix6 :: (k -> TYPE 'IntRep) -> k
+-- newtype instance Dix6 f where
+--   DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff


=====================================
testsuite/tests/typecheck/should_compile/T25725.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies, PolyKinds #-}
+
+module T25725 where
+
+import Data.Kind
+import GHC.Exts
+
+--This one was OK
+data D :: TYPE r -> Type where
+  MkD :: p -> D p
+
+-- now this is OK too
+data family Dix4 :: Type -> k
+data instance Dix4 Int :: TYPE r -> Type where
+  DIn4 :: p -> Dix4 Int p
+
+


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -933,3 +933,7 @@ test('T25266', normal, compile, [''])
 test('T25266a', normal, compile_fail, [''])
 test('T25266b', normal, compile, [''])
 test('T25597', normal, compile, [''])
+test('T25647a', normal, compile, [''])
+test('T25647b', normal, compile, [''])
+test('T25647_fail', normal, compile_fail, [''])
+test('T25725', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfdbaffc3bdab06e453c4e067e6deeb89bdd28ad...88dfabaae0cf0492fbc23e9ddc352d47dc78f17d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfdbaffc3bdab06e453c4e067e6deeb89bdd28ad...88dfabaae0cf0492fbc23e9ddc352d47dc78f17d
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250208/658a459e/attachment-0001.html>
