Add fake entries into the global kind environment for pattern synonyms.
authorDr. ERDI Gergo <gergo@erdi.hu>
Sat, 21 Jun 2014 14:37:50 +0000 (22:37 +0800)
committerDr. ERDI Gergo <gergo@erdi.hu>
Sat, 21 Jun 2014 15:34:34 +0000 (23:34 +0800)
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
compiler/typecheck/TcHsType.lhs
testsuite/tests/patsyn/should_fail/T9161-1.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T9161-1.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T9161-2.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T9161-2.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T

index 516d4fc..273ef82 100644 (file)
@@ -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
index 59aafea..eb3dd32 100644 (file)
@@ -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
diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.hs b/testsuite/tests/patsyn/should_fail/T9161-1.hs
new file mode 100644 (file)
index 0000000..c14eb54
--- /dev/null
@@ -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 (file)
index 0000000..1f05196
--- /dev/null
@@ -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 (file)
index 0000000..941d23e
--- /dev/null
@@ -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 (file)
index 0000000..8d21be5
--- /dev/null
@@ -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 ()
index 897808e..bff6bdf 100644 (file)
@@ -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, [''])