[project @ 2005-03-15 15:40:23 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index b008bbe..3d951b7 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -39,7 +39,7 @@ import TcType         ( TcKind, ThetaType, TcType, tyVarsOfType,
 import Type            ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
 import Generics                ( validGenericMethodType, canDoGenerics )
 import Class           ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
-import TyCon           ( TyCon, ArgVrcs, 
+import TyCon           ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
                          tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
                          tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
 import DataCon         ( DataCon, dataConWrapId, dataConName, dataConSig, 
@@ -280,6 +280,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
           ; return (ConDecl name ex_tvs' ex_ctxt' details')}
     kc_con_decl (GadtDecl name ty)
         = do { ty' <- kcHsSigType ty
+            ; traceTc (text "kc_con_decl" <+> ppr name <+> ppr ty')
             ; return (GadtDecl name ty') }
 
     kc_con_details (PrefixCon btys) 
@@ -322,6 +323,8 @@ kcTyClDeclBody decl thing_inside
     kcHsTyVars (tyClDeclTyVars decl)   $ \ kinded_tvs ->
     do         { tc_ty_thing <- tcLookupLocated (tcdLName decl)
        ; let tc_kind = case tc_ty_thing of { AThing k -> k }
+       ; 
+       ; traceTc (text "kcbody" <+> ppr decl <+> ppr tc_kind <+> ppr (map kindedTyVarKind kinded_tvs)  <+> ppr (result_kind decl))
        ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) 
                                   (result_kind decl)
                                   kinded_tvs)
@@ -371,14 +374,29 @@ tcTyClDecl1 calc_vrcs calc_isrec
   { extra_tvs <- tcDataKindSig mb_ksig
   ; let final_tvs = tvs' ++ extra_tvs
   ; stupid_theta <- tcStupidTheta ctxt cons
+
   ; want_generic <- doptM Opt_Generics
+  ; unbox_strict <- doptM Opt_UnboxStrictFields
+  ; gla_exts     <- doptM Opt_GlasgowExts
+  ; is_boot     <- tcIsHsBoot  -- Are we compiling an hs-boot file?
+
+       -- Check that we don't use GADT syntax in H98 world
+  ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+
+       -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+  ; checkTc (not (null cons) || gla_exts || is_boot)
+           (emptyConDeclsErr tc_name)
+    
   ; tycon <- fixM (\ tycon -> do 
-       { unbox_strict <- doptM Opt_UnboxStrictFields
-       ; gla_exts <- doptM Opt_GlasgowExts
-       ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
-
-       ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon final_tvs)) cons
-       ; let tc_rhs = case new_or_data of
+       { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
+                                                tycon final_tvs)) 
+                            cons
+       ; let tc_rhs 
+               | null cons && is_boot  -- In a hs-boot file, empty cons means
+               = AbstractTyCon         -- "don't know"; hence Abstract
+               | otherwise
+               = case new_or_data of
                        DataType -> mkDataTyConRhs stupid_theta data_cons
                        NewType  -> ASSERT( isSingleton data_cons )
                                    mkNewTyConRhs tycon (head data_cons)
@@ -476,7 +494,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs        -- Ordinary data types
 tcConDecl unbox_strict DataType tycon tc_tvs   -- GADTs
          decl@(GadtDecl name con_ty)
   = do { traceTc (text "tcConDecl"  <+> ppr name)
-       ; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty
+       ; (tvs, theta, bangs, arg_tys, data_tc, res_tys) <- tcLHsConSig con_ty
                
        ; traceTc (text "tcConDecl1"  <+> ppr name)
        ; let   -- Now dis-assemble the type, and check its form
@@ -493,7 +511,10 @@ tcConDecl unbox_strict DataType tycon tc_tvs       -- GADTs
        ; buildDataCon (unLoc name) False {- Not infix -} is_vanilla
                       (argStrictness unbox_strict tycon bangs arg_tys)
                       [{- No field labels -}]
-                      tvs' theta arg_tys' tycon res_tys' }
+                      tvs' theta arg_tys' data_tc res_tys' }
+               -- NB:  we put data_tc, the type constructor gotten from the constructor 
+               --      type signature into the data constructor; that way checkValidDataCon 
+               --      can complain if it's wrong.
 
 -------------------
 tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType)
@@ -739,10 +760,15 @@ exRecConErr name
     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 
 badDataConTyCon data_con
-  = hang (ptext SLIT("Data constructor does not return its parent type:"))
-       2 (ppr data_con)
+  = hang (ptext SLIT("Data constructor") <+> quotes (ppr data_con) <+>
+               ptext SLIT("returns type") <+> quotes (ppr (dataConTyCon data_con)))
+       2 (ptext SLIT("instead of its parent type"))
 
 badGadtDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
         , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
+
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+        nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 \end{code}