replace several 'fromJust's with 'expectJust's

[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index e533cca..9e0b6cc 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -44,16 +44,16 @@ import Generics             ( validGenericMethodType, canDoGenerics )
 import Class           ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
 import TyCon           ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
                          tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
-                         tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
+                         tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
 import DataCon         ( DataCon, dataConWrapId, dataConName, 
-                         -- dataConSig, 
                          dataConFieldLabels, dataConTyCon,
                          dataConTyVars, dataConFieldType, dataConResTys )
 import Var             ( TyVar, idType, idName )
 import VarSet          ( elemVarSet, mkVarSet )
 import Name            ( Name, getSrcLoc )
 import Outputable
-import Maybe           ( isJust, fromJust )
+import Maybe           ( isJust )
+import Maybes          ( expectJust )
 import Unify           ( tcMatchTys, tcMatchTyX )
 import Util            ( zipLazy, isSingleton, notNull, sortLe )
 import List            ( partition )
@@ -621,10 +621,10 @@ checkValidTyCon tc
     mappM_ check_fields groups
 
   where
-    syn_ctxt    = TySynCtxt name
-    name         = tyConName tc
-    (_, syn_rhs) = getSynTyConDefn tc
-    data_cons    = tyConDataCons tc
+    syn_ctxt  = TySynCtxt name
+    name      = tyConName tc
+    syn_rhs   = synTyConRhs tc
+    data_cons = tyConDataCons tc
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
     cmp_fld (f1,_) (f2,_) = f1 `compare` f2
@@ -664,7 +664,7 @@ checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
   where
     mb_subst1 = tcMatchTys tvs1 res1 res2
-    mb_subst2 = tcMatchTyX tvs1 (fromJust mb_subst1) fty1 fty2
+    mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
 
 -------------------------------
 checkValidDataCon :: TyCon -> DataCon -> TcM ()
@@ -754,24 +754,6 @@ fieldTypeMisMatch field_name con1 con2
         ptext SLIT("give different types for field"), quotes (ppr field_name)]
 
 dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con)
-{-     If the data constructor returns the wrong data type, then we get
-       zip_ty_env failures when printing its argument types; so best
-       to be less ambitious about complaining here 
-    nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
-  where
-    (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con
-    ex_part | null ex_tvs = empty
-           | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
-       -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
-       --      data T a = Eq a => T a a
-       -- So we make sure to print it
-
-    fields = dataConFieldLabels con
-    arg_part | null fields = sep (map pprParendType arg_tys)
-            | otherwise   = braces (sep (punctuate comma 
-                            [ ppr n <+> dcolon <+> ppr ty 
-                            | (n,ty) <- fields `zip` arg_tys]))
--}
 
 classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
                              nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]