From 283a346586e5bf711ecd8cc61263d87771f8f744 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 10 Feb 2017 10:31:10 -0500 Subject: [PATCH] Prevent Template Haskell splices from throwing a spurious TypeInType error Summary: There was a rather annoying corner case where splicing poly-kinded Template Haskell declarations could trigger an error muttering about `TypeInType` not being enabled, whereas the equivalent non-TH code would compile without issue. This was causing by overzealous validity check in the renamer, wherein failed to distinguish between two different `Exact` names with the same `OccName`. As a result, it mistakenly believed some type variables were being used as both type and kind variables simultaneously! Ack. This avoids the issue by simply disabling the aforementioned validity check for Exact names. Fixes #12503. Test Plan: ./validate Reviewers: austin, bgamari, goldfire Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D3022 --- compiler/rename/RnTypes.hs | 40 ++++++++++++++++++++++++++++++++++-- testsuite/tests/th/T12503.hs | 29 ++++++++++++++++++++++++++ testsuite/tests/th/all.T | 1 + 3 files changed, 68 insertions(+), 2 deletions(-) create mode 100644 testsuite/tests/th/T12503.hs diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 91d697899a..9cf78c2338 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1692,18 +1692,20 @@ extract_tv t_or_k ltv@(L _ tv) acc | isRdrTyVar tv = case acc of FKTV kvs k_set tvs t_set all | isTypeLevel t_or_k - -> do { when (occ `elemOccSet` k_set) $ + -> do { when (not_exact && occ `elemOccSet` k_set) $ mixedVarsErr ltv ; return (FKTV kvs k_set (ltv : tvs) (t_set `extendOccSet` occ) (ltv : all)) } | otherwise - -> do { when (occ `elemOccSet` t_set) $ + -> do { when (not_exact && occ `elemOccSet` t_set) $ mixedVarsErr ltv ; return (FKTV (ltv : kvs) (k_set `extendOccSet` occ) tvs t_set (ltv : all)) } | otherwise = return acc where occ = rdrNameOcc tv + -- See Note [TypeInType validity checking and Template Haskell] + not_exact = not $ isExact tv mixedVarsErr :: Located RdrName -> RnM () mixedVarsErr (L loc tv) @@ -1716,3 +1718,37 @@ mixedVarsErr (L loc tv) -- just used in this module; seemed convenient here nubL :: Eq a => [Located a] -> [Located a] nubL = nubBy eqLocated + +{- +Note [TypeInType validity checking and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +extract_tv enforces an invariant that no variable can be used as both a kind +and a type unless -XTypeInType is enabled. It does so by accumulating two sets +of variables' OccNames (one for type variables and one for kind variables) that +it has seen before. If a new type variable's OccName appears in the kind set, +then it errors, and similarly for kind variables and the type set. + +This relies on the assumption that any two variables with the same OccName +are the same. While this is always true of user-written code, it is not always +true in the presence of Template Haskell! GHC Trac #12503 demonstrates a +scenario where two different Exact TH-generated names can have the same +OccName. As a result, if one of these Exact names is for a type variable +and the other Exact name is for a kind variable, then extracting them both +can lead to a spurious error in extract_tv. + +To avoid such a scenario, we simply don't check the invariant in extract_tv +when the name is Exact. This allows Template Haskell users to write code that +uses -XPolyKinds without needing to enable -XTypeInType. + +This is a somewhat arbitrary design choice, as adding this special case causes +this code to be accepted when spliced in via Template Haskell: + + data T1 k e + class C1 b + instance C1 (T1 k (e :: k)) + +Even if -XTypeInType is _not enabled. But accepting too many programs without +the prerequisite GHC extensions is better than the alternative, where some +programs would not be accepted unless enabling an extension which has nothing +to do with the code itself. +-} diff --git a/testsuite/tests/th/T12503.hs b/testsuite/tests/th/T12503.hs new file mode 100644 index 0000000000..517c4ba156 --- /dev/null +++ b/testsuite/tests/th/T12503.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module T12503 where + +import Language.Haskell.TH + +data T1 k +class C1 a + +$(do TyConI (DataD [] tName [ KindedTV kName kKind] _ _ _) + <- reify ''T1 + d <- instanceD (cxt []) + (conT ''C1 `appT` + (conT tName `appT` sigT (varT kName) kKind)) + [] + return [d]) + +data family T2 (a :: b) +data instance T2 b +class C2 a + +$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ [tyVar] _ _ _] + <- reify ''T2 + d <- instanceD (cxt []) + (conT ''C2 `appT` (conT tName `appT` return tyVar)) + [] + return [d]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 9a08b6542c..56aca1a978 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -363,6 +363,7 @@ test('T12478_2', omit_ways(['ghci']), compile_and_run, ['-v0']) test('T12478_3', omit_ways(['ghci']), compile, ['-v0']) test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0']) test('T12478_5', omit_ways(['ghci']), compile, ['-v0']) +test('T12503', normal, compile, ['-v0']) test('T12513', omit_ways(['ghci']), compile_fail, ['-v0']) test('T12530', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T12646', normal, compile, ['-v0']) -- GitLab