Fix scoping of data cons during kind checking
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 19 May 2017 13:57:59 +0000 (14:57 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 19 May 2017 13:57:59 +0000 (14:57 +0100)
Trac #13625 pointed out that in

   data X :: Y where Y :: X

we need 'Y' to be in scope (as APromotionErr) when dealing with
X's kind signature.  Previously we got a crash.

This patch simplifies the code as well as making it work.

compiler/typecheck/TcEnv.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcTyClsDecls.hs
testsuite/tests/polykinds/T13625.hs [new file with mode: 0644]
testsuite/tests/polykinds/T13625.stderr [new file with mode: 0644]
testsuite/tests/polykinds/all.T

index bec62c8..b4d873a 100644 (file)
@@ -26,7 +26,7 @@ module TcEnv(
         lookupGlobal,
 
         -- Local environment
-        tcExtendKindEnv2,
+        tcExtendKindEnv, tcExtendKindEnvList,
         tcExtendTyVarEnv, tcExtendTyVarEnv2,
         tcExtendLetEnv, tcExtendLetEnvIds,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
@@ -368,16 +368,24 @@ getInLocalScope :: TcM (Name -> Bool)
 getInLocalScope = do { lcl_env <- getLclTypeEnv
                      ; return (`elemNameEnv` lcl_env) }
 
-tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r
+tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
 -- Used only during kind checking, for TcThings that are
 --      ATcTyCon or APromotionErr
 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
-tcExtendKindEnv2 things thing_inside
-  = do { traceTc "txExtendKindEnv" (ppr things)
+tcExtendKindEnvList things thing_inside
+  = do { traceTc "txExtendKindEnvList" (ppr things)
        ; updLclEnv upd_env thing_inside }
   where
     upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
 
+tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
+-- A variant of tcExtendKindEvnList
+tcExtendKindEnv extra_env thing_inside
+  = do { traceTc "txExtendKindEnv" (ppr extra_env)
+       ; updLclEnv upd_env thing_inside }
+  where
+    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
+
 -----------------------
 -- Scoped type and kind variables
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
@@ -561,8 +569,8 @@ tcExtendIdBndrs bndrs thing_inside
 tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a
 -- See Note [AFamDataCon: not promoting data family constructors]
 tcAddDataFamConPlaceholders inst_decls thing_inside
-  = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
-                     | lid <- inst_decls, con <- get_cons lid ]
+  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
+                        | lid <- inst_decls, con <- get_cons lid ]
       thing_inside
       -- Note [AFamDataCon: not promoting data family constructors]
   where
@@ -581,8 +589,8 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
 tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a
 -- See Note [Don't promote pattern synonyms]
 tcAddPatSynPlaceholders pat_syns thing_inside
-  = tcExtendKindEnv2 [ (name, APromotionErr PatSynPE)
-                     | PSB{ psb_id = L _ name } <- pat_syns ]
+  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
+                        | PSB{ psb_id = L _ name } <- pat_syns ]
        thing_inside
 
 getTypeSigNames :: [LSig Name] -> NameSet
index 481b2a7..e5e9eb2 100644 (file)
@@ -144,7 +144,7 @@ import HscTypes
 import TcEvidence
 import Type
 import Class    ( Class )
-import TyCon    ( TyCon )
+import TyCon    ( TyCon, tyConKind )
 import Coercion ( Coercion, mkHoleCo )
 import ConLike  ( ConLike(..) )
 import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
@@ -1083,7 +1083,7 @@ instance Outputable TcTyThing where     -- Debugging only
                                  <> ppr (varType (tct_id elt)) <> comma
                                  <+> ppr (tct_info elt))
    ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv
-   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc
+   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)
    ppr (APromotionErr err) = text "APromotionErr" <+> ppr err
 
 -- | Describes how an Id is bound.
index 0010492..ddb183d 100644 (file)
@@ -209,7 +209,7 @@ tcTyClDecls tyclds role_annots
                  -- Also extend the local type envt with bindings giving
                  -- the (polymorphic) kind of each knot-tied TyCon or Class
                  -- See Note [Type checking recursive type and class declarations]
-             tcExtendKindEnv2 (map mkTcTyConPair tc_tycons)              $
+             tcExtendKindEnv (foldl extendEnvWithTcTyCon emptyNameEnv tc_tycons) $
 
                  -- Kind and type check declarations for this group
                mapM (tcTyClDecl roles) tyclds
@@ -340,21 +340,19 @@ kcTyClGroup decls
           -- See Note [Kind checking for type and class decls]
 
         ; lcl_env <- solveEqualities $
-          do {
-               -- Step 1: Bind kind variables for all decls
-               initial_kinds <- getInitialKinds decls
-             ; traceTc "kcTyClGroup: initial kinds" $
-               vcat (map pp_initial_kind initial_kinds)
-             ; tcExtendKindEnv2 initial_kinds $ do {
-
-             -- Step 2: Set extended envt, kind-check the decls
-             ; mapM_ kcLTyClDecl decls
-
-             ; getLclEnv } }
-
-             -- Step 4: generalisation
-             -- Kind checking done for this group
-             -- Now we have to kind generalize the flexis
+                     do { -- Step 1: Bind kind variables for all decls
+                          initial_kinds <- getInitialKinds decls
+                        ; traceTc "kcTyClGroup: initial kinds" $
+                          ppr initial_kinds
+
+                        -- Step 2: Set extended envt, kind-check the decls
+                        ; tcExtendKindEnv initial_kinds $
+                          do { mapM_ kcLTyClDecl decls
+                             ; getLclEnv } }
+
+        -- Step 3: generalisation
+        -- Kind checking done for this group
+        -- Now we have to kind generalize the flexis
         ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
 
         ; traceTc "kcTyClGroup result" (vcat (map pp_res res))
@@ -407,44 +405,70 @@ kcTyClGroup decls
     generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
       = generalise kind_env name
 
-    pp_initial_kind (name, ATcTyCon tc)
-      = ppr name <+> dcolon <+> ppr (tyConKind tc)
-    pp_initial_kind pair
-      = ppr pair
-
     pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
 
-mkTcTyConPair :: TcTyCon -> (Name, TcTyThing)
+--------------
+mkTcTyConEnv :: TcTyCon -> TcTypeEnv
+mkTcTyConEnv tc = unitNameEnv (getName tc) (ATcTyCon tc)
+
+extendEnvWithTcTyCon :: TcTypeEnv -> TcTyCon -> TcTypeEnv
 -- Makes a binding to put in the local envt, binding
 -- a name to a TcTyCon
-mkTcTyConPair tc
-  = (getName tc, ATcTyCon tc)
-
-mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
-mk_thing_env [] = []
-mk_thing_env (decl : decls)
-  | L _ (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) <- decl
-  = (nm, APromotionErr ClassPE) :
-    (map (, APromotionErr TyConPE) $ map (unLoc . fdLName . unLoc) ats) ++
-    (mk_thing_env decls)
+extendEnvWithTcTyCon env tc
+  = extendNameEnv env (getName tc) (ATcTyCon tc)
+
+--------------
+mkPromotionErrorEnv :: [LTyClDecl Name] -> TcTypeEnv
+-- Maps each tycon/datacon to a suitable promotion error
+--    tc :-> APromotionErr TyConPE
+--    dc :-> APromotionErr RecDataConPE
+--    See Note [ARecDataCon: Recursion and promoting data constructors]
 
-  | otherwise
-  = (tcdName (unLoc decl), APromotionErr TyConPE) :
-    (mk_thing_env decls)
+mkPromotionErrorEnv decls
+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)
+          emptyNameEnv decls
+
+mk_prom_err_env :: TyClDecl Name -> TcTypeEnv
+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })
+  = unitNameEnv nm (APromotionErr ClassPE)
+    `plusNameEnv`
+    mkNameEnv [ (name, APromotionErr TyConPE)
+              | L _ (FamilyDecl { fdLName = L _ name }) <- ats ]
+
+mk_prom_err_env (DataDecl { tcdLName = L _ name
+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })
+  = unitNameEnv name (APromotionErr TyConPE)
+    `plusNameEnv`
+    mkNameEnv [ (con, APromotionErr RecDataConPE)
+              | L _ con' <- cons, L _ con <- getConNames con' ]
+
+mk_prom_err_env decl
+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)
+    -- Works for family declarations too
+
+--------------
+getInitialKinds :: [LTyClDecl Name] -> TcM (NameEnv TcTyThing)
+-- Maps each tycon to its initial kind,
+-- and each datacon to a suitable promotion error
+--    tc :-> ATcTyCon (tc:initial_kind)
+--    dc :-> APromotionErr RecDataConPE
+--    See Note [ARecDataCon: Recursion and promoting data constructors]
 
-getInitialKinds :: [LTyClDecl Name] -> TcM [(Name, TcTyThing)]
 getInitialKinds decls
-  = tcExtendKindEnv2 (mk_thing_env decls) $
-    do { pairss <- mapM (addLocM getInitialKind) decls
-       ; return (concat pairss) }
+  = tcExtendKindEnv promotion_err_env $
+    do { tc_kinds <- mapM (addLocM getInitialKind) decls
+       ; return (foldl plusNameEnv promotion_err_env tc_kinds) }
+  where
+    promotion_err_env = mkPromotionErrorEnv decls
 
 getInitialKind :: TyClDecl Name
-               -> TcM [(Name, TcTyThing)]    -- Mixture of ATcTyCon and APromotionErr
+               -> TcM (NameEnv TcTyThing)
 -- Allocate a fresh kind variable for each TyCon and Class
--- For each tycon, return   (name, ATcTyCon (TcCyCon with kind k))
---                 where k is the kind of tc, derived from the LHS
---                       of the definition (and probably including
---                       kind unification variables)
+-- For each tycon, return a NameEnv with
+--      name :-> ATcTyCon (TcCyCon with kind k))
+-- where k is the kind of tc, derived from the LHS
+--       of the definition (and probably including
+--       kind unification variables)
 --      Example: data T a b = ...
 --      return (T, kv1 -> kv2 -> kv3)
 --
@@ -452,33 +476,26 @@ getInitialKind :: TyClDecl Name
 --   * The kind signatures on type-variable binders
 --   * The result kinds signature on a TyClDecl
 --
--- ALSO for each datacon, return (dc, APromotionErr RecDataConPE)
---    See Note [ARecDataCon: Recursion and promoting data constructors]
---
 -- No family instances are passed to getInitialKinds
 
 getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
-  = do { (tycon, inner_prs) <-
+  = do { let cusk = hsDeclHasCusk decl
+       ; (tycon, inner_prs) <-
            kcHsTyVarBndrs name True cusk False True ktvs $
            do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
               ; return (constraintKind, inner_prs) }
-       ; return (mkTcTyConPair tycon : inner_prs) }
-  where
-    cusk = hsDeclHasCusk decl
+       ; return (extendEnvWithTcTyCon inner_prs tycon) }
 
 getInitialKind decl@(DataDecl { tcdLName = L _ name
                               , tcdTyVars = ktvs
-                              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
-                                                         , dd_cons = cons } })
+                              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig } })
   = do  { (tycon, _) <-
            kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $
            do { res_k <- case m_sig of
                            Just ksig -> tcLHsKind ksig
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
-        ; let inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
-                          | L _ con' <- cons, con <- getConNames con' ]
-        ; return (mkTcTyConPair tycon : inner_prs) }
+        ; return (mkTcTyConEnv tycon) }
 
 getInitialKind (FamDecl { tcdFam = decl })
   = getFamDeclInitialKind Nothing decl
@@ -492,7 +509,7 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name
                             Nothing -> newMetaKindVar
                             Just ksig -> tcLHsKind ksig
                 ; return (res_k, ()) }
-        ; return [ mkTcTyConPair tycon ] }
+        ; return (mkTcTyConEnv tycon) }
   where
     -- Keep this synchronized with 'hsDeclHasCusk'.
     kind_annotation (L _ ty) = case ty of
@@ -502,15 +519,15 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name
 
 ---------------------------------
 getFamDeclInitialKinds :: Maybe Bool  -- if assoc., CUSKness of assoc. class
-                       -> [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
+                       -> [LFamilyDecl Name]
+                       -> TcM TcTypeEnv
 getFamDeclInitialKinds mb_cusk decls
-  = tcExtendKindEnv2 [ (n, APromotionErr TyConPE)
-                     | L _ (FamilyDecl { fdLName = L _ n }) <- decls] $
-    concatMapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
+  = do { tc_kinds <- mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
+       ; return (foldr plusNameEnv emptyNameEnv tc_kinds) }
 
 getFamDeclInitialKind :: Maybe Bool  -- if assoc., CUSKness of assoc. class
                       -> FamilyDecl Name
-                      -> TcM [(Name, TcTyThing)]
+                      -> TcM TcTypeEnv
 getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
                                                , fdTyVars    = ktvs
                                                , fdResultSig = L _ resultSig
@@ -526,7 +543,7 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
                         -- by default
                         | otherwise                -> newMetaKindVar
               ; return (res_k, ()) }
-       ; return [ mkTcTyConPair tycon ] }
+       ; return (mkTcTyConEnv tycon) }
   where
     cusk  = famDeclHasCusk mb_cusk decl
     (open, unsat) = case info of
diff --git a/testsuite/tests/polykinds/T13625.hs b/testsuite/tests/polykinds/T13625.hs
new file mode 100644 (file)
index 0000000..62d3461
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeInType #-}
+
+module T13625 where
+
+data X :: Y where Y :: X
diff --git a/testsuite/tests/polykinds/T13625.stderr b/testsuite/tests/polykinds/T13625.stderr
new file mode 100644 (file)
index 0000000..4e0d4b6
--- /dev/null
@@ -0,0 +1,5 @@
+
+T13625.hs:5:11: error:
+    • Data constructor ‘Y’ cannot be used here
+        (it is defined and used in the same recursive group)
+    • In the kind ‘Y’
index 28d33c1..900faca 100644 (file)
@@ -162,3 +162,4 @@ test('T13371', normal, compile, [''])
 test('T13393', normal, compile_fail, [''])
 test('T13555', normal, compile_fail, [''])
 test('T13659', normal, compile_fail, [''])
+test('T13625', normal, compile_fail, [''])