Add fake entries into the global kind environment for pattern synonyms.

This is needed to give meaningful error messages (instead of internal
panics) when a program tries to lift a pattern synonym into a kind.
(fixes T9161)

compiler/typecheck/TcBinds.lhs

@@ -281,19 +281,28 @@ tcValBinds :: TopLevelFlag
            -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
 
 tcValBinds top_lvl binds sigs thing_inside
-  = do  {       -- Typecheck the signature
-          (poly_ids, sig_fn) <- tcTySigs sigs
+  = do  {       -- Add fake entries for pattern synonyms so that
+                -- precise error messages can be generated when
+                -- trying to use a pattern synonym as a kind
+          traceTc "Fake lifted patsyns:" (vcat (map ppr patsyns))
+                -- Typecheck the signature
+        ; (poly_ids, sig_fn) <- tcExtendKindEnv2 [(patsyn, fakePatSynCon) | patsyn <- patsyns] $
+                                tcTySigs sigs
 
         ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
 
                 -- Extend the envt right away with all 
                 -- the Ids declared with type signatures
                 -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
-        ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
-                             tcBindGroups top_lvl sig_fn prag_fn 
-                                          binds thing_inside
-
-        ; return (binds', thing) }
+        ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
+            tcBindGroups top_lvl sig_fn prag_fn
+                         binds thing_inside }
+  where
+    patsyns = [ name
+              | (_, lbinds) <- binds
+              , L _ (PatSynBind{ patsyn_id = L _ name }) <- bagToList lbinds
+              ]
+    fakePatSynCon = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
 
 ------------------------
 tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun

compiler/typecheck/TcHsType.lhs

@@ -625,7 +625,6 @@ tcTyVar :: Name -> TcM (TcType, TcKind)
 tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
   = do { traceTc "lk1" (ppr name)
        ; thing <- tcLookup name
-       ; traceTc "lk2" (ppr name <+> ppr thing)
        ; case thing of
            ATyVar _ tv 
               | isKindVar tv

testsuite/tests/patsyn/should_fail/T9161-1.hs

+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DataKinds #-}
+
+pattern PATTERN = ()
+
+wrongLift :: PATTERN
+wrongLift = undefined

testsuite/tests/patsyn/should_fail/T9161-1.stderr

+
+T9161-1.hs:6:14:
+    Pattern synonym ‘PATTERN’ used as a type
+    In the type signature for ‘wrongLift’: wrongLift :: PATTERN

testsuite/tests/patsyn/should_fail/T9161-2.hs

+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
+
+pattern PATTERN = ()
+
+data Proxy (tag :: k) (a :: *)
+
+wrongLift :: Proxy PATTERN ()
+wrongLift = undefined

testsuite/tests/patsyn/should_fail/T9161-2.stderr

+
+T9161-2.hs:8:20:
+    Pattern synonym ‘PATTERN’ used as a type
+    In the type signature for ‘wrongLift’:
+      wrongLift :: Proxy PATTERN ()

testsuite/tests/patsyn/should_fail/all.T

@@ -4,3 +4,5 @@ test('unidir', normal, compile_fail, [''])
 test('local', normal, compile_fail, [''])
 test('T8961', normal, multimod_compile_fail, ['T8961',''])
 test('as-pattern', normal, compile_fail, [''])
+test('T9161-1', normal, compile_fail, [''])
+test('T9161-2', normal, compile_fail, [''])