[commit: ghc] master: Move check for dcUserTyVarBinders invariant (fe0fa63)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/fe0fa63ebe63862e5515a0deaf25f63825c238db/ghc

>---------------------------------------------------------------

commit fe0fa63ebe63862e5515a0deaf25f63825c238db
Author: Richard Eisenberg <rae at cs.brynmawr.edu>
Date:   Thu Jul 12 17:48:39 2018 -0400

    Move check for dcUserTyVarBinders invariant
    
    Previously, this check was done in mkDataCon. But this
    sometimes caused assertion failures if an invalid data
    con was made. I've moved the check to checkValidDataCon,
    where we can be sure the datacon is otherwise valid first.


>---------------------------------------------------------------

fe0fa63ebe63862e5515a0deaf25f63825c238db
 compiler/basicTypes/DataCon.hs     | 19 +++----------------
 compiler/typecheck/TcTyClsDecls.hs | 19 +++++++++++++++++++
 2 files changed, 22 insertions(+), 16 deletions(-)

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 5e7b4cb..f174130 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -87,7 +87,6 @@ import qualified Data.Data as Data
 import Data.Char
 import Data.Word
 import Data.List( find )
-import qualified Data.Set as Set
 
 {-
 Data constructor representation
@@ -887,24 +886,12 @@ mkDataCon name declared_infix prom_info
   = con
   where
     is_vanilla = null ex_tvs && null eq_spec && null theta
-    -- Check the dcUserTyVarBinders invariant
-    -- (see Note [DataCon user type variable binders])
-    user_tvbs_invariant =
-         Set.fromList (filterEqSpec eq_spec univ_tvs ++ ex_tvs)
-      == Set.fromList (binderVars user_tvbs)
-    user_tvbs' =
-      ASSERT2( user_tvbs_invariant
-             , (vcat [ ppr name
-                     , ppr univ_tvs
-                     , ppr ex_tvs
-                     , ppr eq_spec
-                     , ppr user_tvbs ]) )
-      user_tvbs
+
     con = MkData {dcName = name, dcUnique = nameUnique name,
                   dcVanilla = is_vanilla, dcInfix = declared_infix,
                   dcUnivTyVars = univ_tvs,
                   dcExTyVars = ex_tvs,
-                  dcUserTyVarBinders = user_tvbs',
+                  dcUserTyVarBinders = user_tvbs,
                   dcEqSpec = eq_spec,
                   dcOtherTheta = theta,
                   dcStupidTheta = stupid_theta,
@@ -937,7 +924,7 @@ mkDataCon name declared_infix prom_info
 
       -- See Note [Promoted data constructors] in TyCon
     prom_tv_bndrs = [ mkNamedTyConBinder vis tv
-                    | TvBndr tv vis <- user_tvbs' ]
+                    | TvBndr tv vis <- user_tvbs ]
 
     prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)
     prom_res_kind  = orig_res_ty
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 308fbb9..bb350a7 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -76,6 +76,8 @@ import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad
 import Data.List
 import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.Set as Set
+
 
 {-
 ************************************************************************
@@ -2720,6 +2722,23 @@ checkValidDataCon dflags existential_ok tc con
           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
         ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
 
+          -- Check the dcUserTyVarBinders invariant
+          -- See Note [DataCon user type variable binders] in DataCon
+          -- checked here because we sometimes build invalid DataCons before
+          -- erroring above here
+        ; when debugIsOn $
+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con
+                   user_tvs                       = dataConUserTyVars con
+                   user_tvbs_invariant
+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)
+                       == Set.fromList user_tvs
+             ; MASSERT2( user_tvbs_invariant
+                       , vcat ([ ppr con
+                               , ppr univs
+                               , ppr exs
+                               , ppr eq_spec
+                               , ppr user_tvs ])) }
+
         ; traceTc "Done validity of data con" $
           vcat [ ppr con
                , text "Datacon user type:" <+> ppr (dataConUserType con)