diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index a15d52040b568c70e1c84c00ebc0ce2b043a80d9..65ad0011aaa65c96605ffee2be5b05ed9e0bfa82 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -277,19 +277,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 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index e4a34d966dc4e34f749c6040ef68a788456749a0..8e1f361ad32baafccd5cc6a48ee4c2b8fe65afd8 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -618,7 +618,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 diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.hs b/testsuite/tests/patsyn/should_fail/T9161-1.hs new file mode 100644 index 0000000000000000000000000000000000000000..c14eb542cc339bfc9524e206cde2780df7124e20 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T9161-1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} + +pattern PATTERN = () + +wrongLift :: PATTERN +wrongLift = undefined diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.stderr b/testsuite/tests/patsyn/should_fail/T9161-1.stderr new file mode 100644 index 0000000000000000000000000000000000000000..1f05196ebb218bcce668a6761c3afd5835b43775 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T9161-1.stderr @@ -0,0 +1,4 @@ + +T9161-1.hs:6:14: + Pattern synonym ‘PATTERN’ used as a type + In the type signature for ‘wrongLift’: wrongLift :: PATTERN diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.hs b/testsuite/tests/patsyn/should_fail/T9161-2.hs new file mode 100644 index 0000000000000000000000000000000000000000..941d23e35fb0f5c889a7c30f640645de8b338974 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T9161-2.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-} + +pattern PATTERN = () + +data Proxy (tag :: k) (a :: *) + +wrongLift :: Proxy PATTERN () +wrongLift = undefined diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.stderr b/testsuite/tests/patsyn/should_fail/T9161-2.stderr new file mode 100644 index 0000000000000000000000000000000000000000..8d21be5906b9a33e6dafed5cd6d3a0664a05b122 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T9161-2.stderr @@ -0,0 +1,5 @@ + +T9161-2.hs:8:20: + Pattern synonym ‘PATTERN’ used as a type + In the type signature for ‘wrongLift’: + wrongLift :: Proxy PATTERN () diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 897808ef1d0a7234c4af5d00f8825e9907c03fc2..bff6bdf8c2471aebc8c6e4e2d77d295eeb6a4136 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/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, [''])