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 03def8c..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 )
@@ -404,6 +404,7 @@ tcTyClDecl1 calc_vrcs calc_isrec
   ; checkTc (not (null cons) || gla_exts || is_boot)
            (emptyConDeclsErr tc_name)
     
+       -- Check that a newtype has exactly one constructor
   ; checkTc (new_or_data == DataType || isSingleton cons) 
            (newtypeConError tc_name (length cons))
 
@@ -467,18 +468,21 @@ tcConDecl :: Bool                 -- True <=> -funbox-strict_fields
 
 tcConDecl unbox_strict NewType tycon tc_tvs    -- Newtypes
          (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
-  = ASSERT( null ex_tvs && null (unLoc ex_ctxt) )      
-    do { let tc_datacon field_lbls arg_ty
+  = do { let tc_datacon field_lbls arg_ty
                = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
                     ; buildDataCon (unLoc name) False {- Prefix -} 
                                    True {- Vanilla -} [NotMarkedStrict]
                                    (map unLoc field_lbls)
                                    tc_tvs [] [arg_ty']
                                    tycon (mkTyVarTys tc_tvs) }
+
+               -- Check that a newtype has no existential stuff
+       ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
+
        ; case details of
            PrefixCon [arg_ty] -> tc_datacon [] arg_ty
            RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
-           other -> failWithTc (newTypeFieldErr name (length (hsConArgs details)))
+           other -> failWithTc (newtypeFieldErr name (length (hsConArgs details)))
                        -- Check that the constructor has exactly one field
        }
 
@@ -617,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
@@ -660,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 ()
@@ -750,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)]
@@ -824,10 +810,14 @@ badGadtDecl tc_name
         , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
 
 newtypeConError tycon n
-  = sep [ptext SLIT("A newtype must have exactly one constructor"),
+  = sep [ptext SLIT("A newtype must have exactly one constructor,"),
         nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ]
 
-newTypeFieldErr con_name n_flds
+newtypeExError con
+  = sep [ptext SLIT("A newtype constructor cannot have an existential context,"),
+        nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")]
+
+newtypeFieldErr con_name n_flds
   = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]