Make better "fake tycons" in error recovery
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 15 Jun 2018 08:46:30 +0000 (09:46 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 15 Jun 2018 08:47:41 +0000 (09:47 +0100)
Consider (Trac #15215)
  data T a = MkT ...
  data S a = ...T...MkT....

If there is an error in the definition of 'T' we add a
"fake type constructor" to the type environment, so that we
can continue to typecheck 'S'.  But we /were not/ adding
a fake anything for 'MkT' and so there was an internal
error when we met 'MkT' in the body of 'S'.

The fix is to add fake tycons for all the 'implicits' of 'T'.
This is done by mk_fake_tc in TcTyClsDecls.checkValidTyCl,
which now returns a /list/ of TyCons rather than just one.

On the way I did some refactoring:

* Rename TcTyDecls.tcAddImplicits to tcAddTyConsToGblEnv
  and make it /include/ the TyCons themeselves as well
  as their implicits

* Some incidental refactoring about tcRecSelBinds. The main
  thing is that I've avoided creating a HsValBinds that we
  immediately decompose.  That meant moving some deck chairs
  around.

NB: The new error message for the regression test T15215
has the opaque error "Illegal constraint in a type:", flagged
in Trac #14845.  But that's the fault of the latter ticket.
The fix here not to blame.

compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
testsuite/tests/dependent/should_fail/T15215.hs [new file with mode: 0644]
testsuite/tests/dependent/should_fail/T15215.stderr [new file with mode: 0644]
testsuite/tests/dependent/should_fail/all.T

index fadf0e9..468950a 100644 (file)
@@ -9,7 +9,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
+module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
                  tcHsBootSigs, tcPolyCheck,
                  addTypecheckedBinds,
                  chooseInferredQuantifiers,
@@ -304,15 +304,6 @@ tcCompleteSigs sigs =
                                <+> quotes (ppr tc'))
   in  mapMaybeM (addLocM doOne) sigs
 
-tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
-tcRecSelBinds (XValBindsLR (NValBinds binds sigs))
-  = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
-    do { (rec_sel_binds, tcg_env) <- discardWarnings $
-                                     tcValBinds TopLevel binds sigs getGblEnv
-       ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
-       ; return tcg_env' }
-tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds"
-
 tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
index 0d875d7..4ea49ad 100644 (file)
@@ -330,7 +330,7 @@ setGlobalTypeEnv tcg_env new_type_env
 
 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
   -- Just extend the global environment with some TyThings
-  -- Do not extend tcg_tcs etc
+  -- Do not extend tcg_tcs, tcg_patsyns etc
 tcExtendGlobalEnvImplicit things thing_inside
    = do { tcg_env <- getGblEnv
         ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
index 13b91d5..1d99978 100644 (file)
@@ -19,6 +19,7 @@ import GhcPrelude
 import HsSyn
 import TcBinds
 import TcTyClsDecls
+import TcTyDecls ( addTyConsToGblEnv )
 import TcClassDcl( tcClassDecl2, tcATDefault,
                    HsSigFun, mkHsSigFun,
                    findMethodBind, instantiateMethod )
@@ -416,13 +417,12 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a
 --        (b) the type envt with stuff from data type decls
 addFamInsts fam_insts thing_inside
   = tcExtendLocalFamInstEnv fam_insts $
-    tcExtendGlobalEnv axioms $
-    tcExtendTyConEnv data_rep_tycons  $
+    tcExtendGlobalEnv axioms          $
     do { traceTc "addFamInsts" (pprFamInsts fam_insts)
-       ; tcg_env <- tcAddImplicits data_rep_tycons
-                    -- Does not add its axiom; that comes from
-                    -- adding the 'axioms' above
-       ; setGblEnv tcg_env thing_inside }
+       ; gbl_env <- addTyConsToGblEnv data_rep_tycons
+                    -- Does not add its axiom; that comes
+                    -- from adding the 'axioms' above
+       ; setGblEnv gbl_env thing_inside }
   where
     axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
     data_rep_tycons = famInstsRepTyCons fam_insts
index fdb9ead..a8089b7 100644 (file)
@@ -709,12 +709,10 @@ tcPatSynMatcher (L loc name) lpat
 
 mkPatSynRecSelBinds :: PatSyn
                     -> [FieldLabel]  -- ^ Visible field labels
-                    -> HsValBinds GhcRn
+                    -> [(Id, LHsBind GhcRn)]
 mkPatSynRecSelBinds ps fields
-  = XValBindsLR (NValBinds selector_binds sigs)
-  where
-    (sigs, selector_binds) = unzip (map mkRecSel fields)
-    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+    | fld_lbl <- fields ]
 
 isUnidirectional :: HsPatSynDir a -> Bool
 isUnidirectional Unidirectional          = True
index 729be95..0e095de 100644 (file)
@@ -10,7 +10,7 @@ TcTyClsDecls: Typecheck type and class declarations
 {-# LANGUAGE TypeFamilies #-}
 
 module TcTyClsDecls (
-        tcTyAndClassDecls, tcAddImplicits,
+        tcTyAndClassDecls,
 
         -- Functions used by TcInstDcls to check
         -- data/type family instance declarations
@@ -69,6 +69,7 @@ import SrcLoc
 import ListSetOps
 import DynFlags
 import Unique
+import ConLike( ConLike(..) )
 import BasicTypes
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -167,7 +168,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
            -- Do it before Step 3 (adding implicit things) because the latter
            -- expects well-formed TyCons
        ; traceTc "Starting validity check" (ppr tyclss)
-       ; tyclss <- mapM checkValidTyCl tyclss
+       ; tyclss <- concatMapM checkValidTyCl tyclss
        ; traceTc "Done validity check" (ppr tyclss)
        ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
            -- See Note [Check role annotations in a second pass]
@@ -177,14 +178,12 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
            -- Step 3: Add the implicit things;
            -- we want them in the environment because
            -- they may be mentioned in interface files
-       ; tcExtendTyConEnv tyclss $
-    do { gbl_env <- tcAddImplicits tyclss
+       ; gbl_env <- addTyConsToGblEnv tyclss
+
+           -- Step 4: check instance declarations
        ; setGblEnv gbl_env $
-    do {
-            -- Step 4: check instance declarations
-       ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds
+         tcInstDecls1 instds }
 
-       ; return (gbl_env, inst_info, datafam_deriv_info) } } }
 tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"
 
 tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
@@ -2450,7 +2449,11 @@ Validity checking is done once the mutually-recursive knot has been
 tied, so we can look at things freely.
 -}
 
-checkValidTyCl :: TyCon -> TcM TyCon
+checkValidTyCl :: TyCon -> TcM [TyCon]
+-- The returned list is either a singleton (if valid)
+-- or a list of "fake tycons" (if not); the fake tycons
+-- include any implicits, like promoted data constructors
+-- See Note [Recover from validity error]
 checkValidTyCl tc
   = setSrcSpan (getSrcSpan tc) $
     addTyConCtxt tc $
@@ -2458,15 +2461,19 @@ checkValidTyCl tc
              (do { traceTc "Starting validity for tycon" (ppr tc)
                  ; checkValidTyCon tc
                  ; traceTc "Done validity for tycon" (ppr tc)
-                 ; return tc })
+                 ; return [tc] })
   where
     recovery_code -- See Note [Recover from validity error]
       = do { traceTc "Aborted validity for tycon" (ppr tc)
-           ; return fake_tc }
-    fake_tc | not (isClassTyCon tc)
-            = makeRecoveryTyCon tc
-            | otherwise
-            = tc
+           ; return (concatMap mk_fake_tc $
+                     ATyCon tc : implicitTyConThings tc) }
+
+    mk_fake_tc (ATyCon tc)
+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
+      | otherwise       = [makeRecoveryTyCon tc]
+    mk_fake_tc (AConLike (RealDataCon dc))
+                        = [makeRecoveryTyCon (promoteDataCon dc)]
+    mk_fake_tc _        = []
 
 {- Note [Recover from validity error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2480,14 +2487,29 @@ want to go on checking validity of subsequent type declarations.
 So we replace T with an abstract TyCon which will do no harm.
 See indexed-types/should_fail/BadSock and Trac #10896
 
-Painfully, though, we *don't* want to do this for classes.
-Consider tcfail041:
-   class (?x::Int) => C a where ...
-   instance C Int
-The class is invalid because of the superclass constraint.  But
-we still want it to look like a /class/, else the instance bleats
-that the instance is mal-formed because it hasn't got a class in
-the head.
+Some notes:
+
+* We must make fakes for promoted DataCons too. Consider (Trac #15215)
+      data T a = MkT ...
+      data S a = ...T...MkT....
+  If there is an error in the definition of 'T' we add a "fake type
+  constructor" to the type environment, so that we can continue to
+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'
+  and so there was an internal error when we met 'MkT' in the body of
+  'S'.
+
+* Painfully, we *don't* want to do this for classes.
+  Consider tcfail041:
+     class (?x::Int) => C a where ...
+     instance C Int
+  The class is invalid because of the superclass constraint.  But
+  we still want it to look like a /class/, else the instance bleats
+  that the instance is mal-formed because it hasn't got a class in
+  the head.
+
+  This is really bogus; now we have in scope a Class that is invalid
+  in some way, with unknown downstream consequences.  A better
+  alterantive might be to make a fake class TyCon.  A job for another day.
 -}
 
 -------------------------
index da8221d..cce0f02 100644 (file)
@@ -19,10 +19,10 @@ module TcTyDecls(
         checkClassCycles,
 
         -- * Implicits
-        tcAddImplicits, mkDefaultMethodType,
+        addTyConsToGblEnv, mkDefaultMethodType,
 
         -- * Record selectors
-        mkRecSelBinds, mkOneRecordSelector
+        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
     ) where
 
 #include "HsVersions.h"
@@ -31,7 +31,7 @@ import GhcPrelude
 
 import TcRnMonad
 import TcEnv
-import TcBinds( tcRecSelBinds )
+import TcBinds( tcValBinds, addTypecheckedBinds )
 import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )
 import TcType
 import TysWiredIn( unitTy )
@@ -743,23 +743,24 @@ updateRoleEnv name n role
 *                                                                      *
 ********************************************************************* -}
 
-tcAddImplicits :: [TyCon] -> TcM TcGblEnv
+addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
 -- Given a [TyCon], add to the TcGblEnv
+--   * extend the TypeEnv with the tycons
 --   * extend the TypeEnv with their implicitTyThings
 --   * extend the TypeEnv with any default method Ids
 --   * add bindings for record selectors
---   * add bindings for type representations for the TyThings
-tcAddImplicits tycons
-  = discardWarnings $
+addTyConsToGblEnv tyclss
+  = tcExtendTyConEnv tyclss                    $
     tcExtendGlobalEnvImplicit implicit_things  $
     tcExtendGlobalValEnv def_meth_ids          $
-    do { traceTc "tcAddImplicits" $ vcat
-            [ text "tycons" <+> ppr tycons
+    do { traceTc "tcAddTyCons" $ vcat
+            [ text "tycons" <+> ppr tyclss
             , text "implicits" <+> ppr implicit_things ]
-       ; tcRecSelBinds (mkRecSelBinds tycons) }
+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+       ; return gbl_env }
  where
-   implicit_things = concatMap implicitTyConThings tycons
-   def_meth_ids    = mkDefaultMethodIds tycons
+   implicit_things = concatMap implicitTyConThings tyclss
+   def_meth_ids    = mkDefaultMethodIds tyclss
 
 mkDefaultMethodIds :: [TyCon] -> [Id]
 -- We want to put the default-method Ids (both vanilla and generic)
@@ -822,30 +823,37 @@ when typechecking the [d| .. |] quote, and typecheck them later.
 ************************************************************************
 -}
 
-mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn
+tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
+tcRecSelBinds sel_bind_prs
+  = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
+    do { (rec_sel_binds, tcg_env) <- discardWarnings $
+                                     tcValBinds TopLevel binds sigs getGblEnv
+       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+  where
+    sigs = [ L loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs
+                                          , let loc = getSrcSpan sel_id ]
+    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
+
+mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
 --    This makes life easier, because the later type checking will add
 --    all necessary type abstractions and applications
 mkRecSelBinds tycons
-  = XValBindsLR (NValBinds binds sigs)
-  where
-    (sigs, binds) = unzip rec_sels
-    rec_sels = map mkRecSelBind [ (tc,fld)
-                                | tc <- tycons
+  = map mkRecSelBind [ (tc,fld) | tc <- tycons
                                 , fld <- tyConFieldLabels tc ]
 
-mkRecSelBind :: (TyCon, FieldLabel) -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn))
+mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
 mkRecSelBind (tycon, fl)
   = mkOneRecordSelector all_cons (RecSelData tycon) fl
   where
     all_cons = map RealDataCon (tyConDataCons tycon)
 
 mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-                    -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn))
+                    -> (Id, LHsBind GhcRn)
 mkOneRecordSelector all_cons idDetails fl
-  = (L loc (IdSig noExt sel_id), (NonRecursive, unitBag (L loc sel_bind)))
+  = (sel_id, L loc sel_bind)
   where
-    loc    = getSrcSpan sel_name
+    loc      = getSrcSpan sel_name
     lbl      = flLabel fl
     sel_name = flSelector fl
 
diff --git a/testsuite/tests/dependent/should_fail/T15215.hs b/testsuite/tests/dependent/should_fail/T15215.hs
new file mode 100644 (file)
index 0000000..96fe043
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+module T15215 where
+
+import Data.Kind
+
+data A :: Type -> Type where
+  MkA :: Show (Maybe a) => A a
+
+data SA :: forall a. A a -> Type where
+  SMkA :: SA MkA
diff --git a/testsuite/tests/dependent/should_fail/T15215.stderr b/testsuite/tests/dependent/should_fail/T15215.stderr
new file mode 100644 (file)
index 0000000..80181b4
--- /dev/null
@@ -0,0 +1,12 @@
+
+T15215.hs:9:3: error:
+    • Non type-variable argument in the constraint: Show (Maybe a)
+      (Use FlexibleContexts to permit this)
+    • In the definition of data constructor ‘MkA’
+      In the data type declaration for ‘A’
+
+T15215.hs:12:14: error:
+    • Illegal constraint in a type: Show (Maybe a0)
+    • In the first argument of ‘SA’, namely ‘MkA’
+      In the type ‘SA MkA’
+      In the definition of data constructor ‘SMkA’
index 5ae037d..8e5185f 100644 (file)
@@ -28,3 +28,4 @@ test('T14066g', normal, compile_fail, [''])
 test('T14066h', normal, compile_fail, [''])
 test('InferDependency', normal, compile_fail, [''])
 test('T15245', normal, compile_fail, [''])
+test('T15215', normal, compile_fail, [''])