+import Data.Coerce

+setElems (LS s) = coerce $ S.elems s

+mapToList (LM m) = coerce $ M.toList m

+        isAlgType, isDataFamilyApp, isSatTyFamApp,

+-- | Check whether a type is a data family type

+isDataFamilyApp :: Type -> Bool

+isDataFamilyApp ty = case tyConAppTyCon_maybe ty of

+                           Just tc -> isDataFamilyTyCon tc

+                           _       -> False

+

+isSatTyFamApp :: Type -> Maybe (TyCon, [Type])

+-- Return the argument if we have a saturated type family application

+-- Why saturated?  See (ATF4) in Note [Apartness and type families]

+isSatTyFamApp (TyConApp tc tys)

+  |  isTypeFamilyTyCon tc

+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated

+  = Just (tc, tys)

+isSatTyFamApp _ = Nothing

+

+    mb_sat_fam_app1 = isSatTyFamApp ty1

+    mb_sat_fam_app2 = isSatTyFamApp ty2

+      | Just (tc2, tys2) <- isSatTyFamApp ty2

+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty

+       ; checkPromotedDataConName env tv Prefix ip name

+        ; checkPromotedDataConName env ty Infix prom op_name

+-- | If a 'Name' is that of a promoted data constructor, perform various

+-- validity checks on it.

+checkPromotedDataConName ::

+  RnTyKiEnv ->

+  -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar'

+  -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names).

+  HsType GhcPs ->

+  -- | Whether the type is written 'Prefix' or 'Infix'.

+  LexicalFixity ->

+  -- | Whether the name was written with an explicit promotion tick or not.

+  PromotionFlag ->

+  -- | The name to check.

+  Name ->

+  TcM ()

+checkPromotedDataConName env ty fixity ip name

+  = do when (isDataConName name && not (isKindName name)) $

+         -- Any use of a promoted data constructor name (that is not

+         -- specifically exempted by isKindName) is illegal without the use

+         -- of DataKinds. See Note [Checking for DataKinds] in

+         -- GHC.Tc.Validity.

+         checkDataKinds env ty

+       when (isDataConName name && not (isPromoted ip)) $

+         addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name)

+

+import GHC.Types.Unique( hasKey )

+import GHC.Builtin.Names( errorMessageTypeErrorFamKey )

+  = case ctOrigin ct of

+      AssocFamPatOrigin         -> True  -- See (CIG1)

+      _                         -> False

+       ; let (suppressed_items, items0) = partition suppressItem tidy_items

+       ; (_, leftovers) <- tryReporters ctxt2 report2 items1

+         -- If there are no other errors to report, report suppressed errors.

+         -- See Note [Suppressing confusing errors].  NB: with -fdefer-type-errors

+         -- we might have reported warnings only from `items0`, but we still want to

+         -- suppress the `suppressed_items`.

+       ; when (null items0) $

+         do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2)

+                                                  suppressed_items

+                 -- ctxt_for_insols: the suppressed errors can be Int~Bool, which

+                 -- will have made the incoming `ctxt` be True; don't make that suppress

+                 -- the Int~Bool error!

+    report1 = [ -- We put implicit lifting errors first, because are solid errors

+                -- See "Implicit lifting" in GHC.Tc.Gen.Splice

+                -- Note [Lifecycle of an untyped splice, and PendingRnSplice]

+                ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter)

+                -- Next, solid equality errors

+

+              -- Next, family applications like (F t1 t2 ~ rigid_ty)

+              -- These could be solved by doing a type-family reduction for F

+              -- which probably means fixing a unfication variable in t1/t2

+              -- See discussion in #26255, where F had an injectivity annotation,

+              -- and we had   [W] F alpha ~ "foo"

+              -- The real error is that the "foo" should be "bar", because there is

+              --    type instance F Int = "bar"

+              -- We could additionally filter on the injectivty annotation,

+              -- but currently we don't.

+              , ("fam app",         is_fam_app_eq,  True, mkGroupReporter mkEqErr)

+

+              -- Put custom type errors after solid equality errors.  In #26255 we

+              -- had a custom error (T <= F alpha) which was suppressing a far more

+              -- informative (K Int ~ [K alpha]). That mismatch between K and [] is

+              -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence

+              -- perhaps be able to solve T <= F alpha, by reducing F Int.

+              --

+              -- Custom errors should precede "non-tv eq", becuase if we have

+              --     () ~ TypeError blah

+              -- we want to report it as a custom error, /not/ as a mis-match

+              -- between TypeError and ()!

+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)

+                 -- (Handles TypeError and Unsatisfiable)

+

+              -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar

+

+    -- Things like (F t1 t2 ~N Maybe s)

+    -- But only proper type families; not (TypeError t1 t2 ~N blah)

+    is_fam_app_eq _ (EqPred NomEq ty1 ty2)

+       | Just (tc,_) <- isSatTyFamApp ty1

+       = not (tc `hasKey` errorMessageTypeErrorFamKey) && isRigidTy ty2

+    is_fam_app_eq _ _  = False

+

+suppressItem :: ErrorItem -> Bool

+ -- See Note [Suppressing confusing errors]

+suppressItem item

+  | Wanted <- ei_flavour item

+  , let orig = errorItemOrigin item

+  = isWantedSuperclassOrigin orig       -- See (SCE1)

+    || isWantedWantedFunDepOrigin orig  -- See (SCE2)

+  | otherwise

+  = False

+

+(SCE1) Superclasses of Wanteds.  These are generated on in case they trigger functional

+   dependencies.  If such a constraint is unsolved, then its "parent" constraint must

+   also be unsolved, and is much more informative to the user.  Example (#26255):

+        class (MinVersion <= F era) => Era era where { ... }

+        f :: forall era. EraFamily era -> IO ()

+        f = ..blah...   -- [W] Era era

+   Here we have simply omitted "Era era =>" from f's type.  But we'll end up with

+   /two/ Wanted constraints:

+        [W] d1 :  Era era

+        [W] d2 : MinVersion <= F era  -- Superclass of d1

+   We definitely want to report d1 and not d2!  Happily it's easy to filter out those

+   superclass-Wanteds, becuase their Origin betrays them.

+

+   See test T18851 for an example of how it is (just, barely) possible for the /only/

+   errors to be superclass-of-Wanted constraints.

+

+(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints.

+(CIG1) Constraints generated in order to unify associated type instance parameters

+(Note: Aug 25: this seems a rather tricky corner;

+               c.f. Note [Suppressing confusing errors])

+

+  | Just {} <- isLitTy ty                   = True

+- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses

+  of promoted data constructors without enabling :extension:`DataKinds`. As a

+  result, you may need to enable :extension:`DataKinds` in code that did not

+  previously require it.

+

+    outer  = StgTRecHeader_enclosing_trec(trec);

+    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");

+    if (r != 0) {

+        // Succeeded (either first branch or second branch)

+        StgTSO_trec(CurrentTSO) = outer;

+        return (ret);

+    } else {

+        // Did not commit: abort and restart.

+        StgTSO_trec(CurrentTSO) = outer;

+        jump stg_abort();

+        // The retry reaches a CATCH_RETRY_FRAME before the atomic frame

+        ASSERT(outer != NO_TREC);

+        // Abort the transaction attempting the current branch

+        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");

+        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");

+            // Retry in the first branch: try the alternative

+            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");

+            StgTSO_trec(CurrentTSO) = trec;

+            // Retry in the alternative code: propagate the retry

+            StgTSO_trec(CurrentTSO) = outer;

+        case CATCH_RETRY_FRAME:

+            // CATCH frames within an atomically block: abort the

+            debugTraceCap(DEBUG_stm, cap,

+                          "found atomically block delivering async exception");

+

+{-

+[W] Show c, Num int, C int A, C int B, C int c

+Superclasses

+   C_FD int ~ A

+   C_FD int ~ B

+   C_FD int ~ c

+-->

+   C_FD int ~ B

+   B ~ A

+-}

+{-# LANGUAGE DataKinds #-}

+{-# LANGUAGE ScopedTypeVariables #-}

+{-# LANGUAGE TypeFamilyDependencies #-}

+{-# LANGUAGE UndecidableSuperClasses #-}

+

+module T26255a where

+

+import Data.Proxy

+import GHC.TypeLits

+

+type MinVersion = 1

+

+class

+  ( KnownNat (ProtVerLow era)

+  , MinVersion <= ProtVerLow era

+  , KnownSymbol (EraName era)

+  ) =>

+  Era era

+  where

+  type EraName era = (r :: Symbol) | r -> era

+

+  type ProtVerLow era :: Nat

+

+  eraName :: Proxy era -> String

+  eraName _ = symbolVal (Proxy :: Proxy (EraName era))

+

+data FooEra

+

+instance Era FooEra where

+  type EraName FooEra = "Foo"

+  type ProtVerLow FooEra = 1

+

+data BarEra

+

+instance Era BarEra where

+  type EraName BarEra = "Bar"

+  type ProtVerLow BarEra = 2

+

+fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era

+fromEraName _ = Proxy

+

+noCompileErrorMessage :: IO ()

+noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar")

+

+brokenCompileErrorMessage1 :: IO ()

+brokenCompileErrorMessage1 = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah")

+

+T26255a.hs:46:51: error: [GHC-18872]

+    • Couldn't match type ‘EraName era0’ with ‘"Blah"’

+        arising from a use of ‘fromEraName’

+      The type variable ‘era0’ is ambiguous

+    • In the second argument of ‘($)’, namely

+        ‘fromEraName (Proxy :: Proxy "Blah")’

+      In the second argument of ‘($)’, namely

+        ‘eraName $ fromEraName (Proxy :: Proxy "Blah")’

+      In the expression:

+        putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah")

+{-# LANGUAGE DataKinds #-}

+{-# LANGUAGE ScopedTypeVariables #-}

+{-# LANGUAGE TypeFamilyDependencies #-}

+{-# LANGUAGE UndecidableSuperClasses #-}

+

+module T26255b where

+

+import Data.Proxy

+import GHC.TypeLits

+

+type MinVersion = 1

+

+class

+  ( KnownNat (ProtVerLow era)

+  , MinVersion <= ProtVerLow era

+  , KnownSymbol (EraName era)

+  ) =>

+  Era era

+  where

+  type EraName era = (r :: Symbol) | r -> era

+

+  type ProtVerLow era :: Nat

+

+  eraName :: Proxy era -> String

+  eraName _ = symbolVal (Proxy :: Proxy (EraName era))

+

+data FooEra

+

+instance Era FooEra where

+  type EraName FooEra = "Foo"

+  type ProtVerLow FooEra = 1

+

+data BarEra

+

+instance Era BarEra where

+  type EraName BarEra = "Bar"

+  type ProtVerLow BarEra = 2

+

+fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era

+fromEraName _ = Proxy

+

+noCompileErrorMessage :: IO ()

+noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar")

+

+brokenCompileErrorMessage2 :: IO ()

+brokenCompileErrorMessage2 = putStrLn $ eraName $ head $ fromEraName (Proxy :: Proxy "Bar")

+T26255b.hs:46:58: error: [GHC-83865]

+    • Couldn't match expected type: [Proxy era0]

+                  with actual type: Proxy BarEra

+    • In the second argument of ‘($)’, namely

+        ‘fromEraName (Proxy :: Proxy "Bar")’

+      In the second argument of ‘($)’, namely

+        ‘head $ fromEraName (Proxy :: Proxy "Bar")’

+      In the second argument of ‘($)’, namely

+        ‘eraName $ head $ fromEraName (Proxy :: Proxy "Bar")’

+{-# LANGUAGE DataKinds #-}

+{-# LANGUAGE FlexibleContexts #-}

+{-# LANGUAGE ScopedTypeVariables #-}

+{-# LANGUAGE TypeFamilyDependencies #-}

+{-# LANGUAGE TypeOperators #-}

+{-# LANGUAGE UndecidableSuperClasses #-}

+

+module T26255c where

+

+import Data.Kind

+import Data.Proxy

+import GHC.TypeLits

+

+type MinVersion = 1

+

+class

+  ( KnownNat (ProtVerLow era)

+  , MinVersion <= ProtVerLow era

+  ) =>

+  Era era

+  where

+  type ProtVerLow era :: Nat

+

+newtype EraFamily era = EraFamily Int

+

+class Era era => NewEra era where

+  eraFamilySize :: EraFamily era -> Int

+

+printEraFamilySize :: EraFamily era -> IO ()

+printEraFamilySize = print . eraFamilySize

+T26255c.hs:30:30: error: [GHC-39999]

+    • No instance for ‘NewEra era’

+        arising from a use of ‘eraFamilySize’

+      Possible fix:

+        add (NewEra era) to the context of

+          the type signature for:

+            printEraFamilySize :: forall {k} (era :: k). EraFamily era -> IO ()

+    • In the second argument of ‘(.)’, namely ‘eraFamilySize’

+      In the expression: print . eraFamilySize

+      In an equation for ‘printEraFamilySize’:

+          printEraFamilySize = print . eraFamilySize

+{-# LANGUAGE GHC2021 #-}

+{-# LANGUAGE NoDataKinds #-}

+module T26318 where

+

+class C1 l

+instance C1 (x : xs)

+

+class C2 l

+instance C2 (x ': xs)

+

+class C3 l

+instance C3 ((:) x xs)

+

+class C4 l

+instance C4 ('(:) x xs)

+T26318.hs:6:16: error: [GHC-68567]

+    Illegal type: ‘x : xs’

+    Suggested fix:

+      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)

+

+T26318.hs:9:16: error: [GHC-68567]

+    Illegal type: ‘x ': xs’

+    Suggested fix:

+      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)

+

+T26318.hs:12:14: error: [GHC-68567]

+    Illegal type: ‘(:)’

+    Suggested fix:

+      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)

+

+T26318.hs:15:14: error: [GHC-68567]

+    Illegal type: ‘'(:)’

+    Suggested fix:

+      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)

+

+UnliftedNewtypesFamilyKindFail2.hs:12:1: error: [GHC-83865]

+    • Expected a type, but ‘F 5’ has kind ‘5’

+    • In the newtype family instance declaration for ‘F’

+

+test('T26318', normal, compile_fail, [''])

+test('T26255a', normal, compile_fail, [''])

+test('T26255b', normal, compile_fail, [''])

+

+        // At this point the RTS symbols in linear memory are fixed

+        // and constructors are run, especially the one in JSFFI.c

+        // that does GHC RTS initialization for any code that links

+        // JSFFI.o. Luckily no Haskell computation or gc has taken

+        // place yet, so we must set keepCAFs=1 right now! Otherwise,

+        // any BCO created by later TH splice or ghci expression may

+        // refer to any CAF that's not reachable from GC roots (here

+        // our only entry point is defaultServer) and the CAF could

+        // have been GC'ed! (#26106)

+        //

+        // We call it here instead of in RTS C code, since we only

+        // want keepCAFs=1 for ghci, not user code.

+        this.exportFuncs.setKeepCAFs();