FIX Trac #1901: check no existential context in H98 mode

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3df2eef..3880f1f 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -6,11 +6,11 @@
 TcTyClsDecls: Typecheck type and class declarations
 
 \begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module TcTyClsDecls (
@@ -140,8 +140,12 @@ indeed type families).  I think.
 tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
                   -> TcM TcGblEnv      -- Input env extended by types and classes 
                                        -- and their implicit Ids,DataCons
+-- Fails if there are any errors
+
 tcTyAndClassDecls boot_details allDecls
-  = do {       -- Omit instances of type families; they are handled together
+  = checkNoErrs $      -- The code recovers internally, but if anything gave rise to
+                       -- an error we'd better stop now, to avoid a cascade
+    do {       -- Omit instances of type families; they are handled together
                -- with the *heads* of class instances
         ; let decls = filter (not . isFamInstDecl . unLoc) allDecls
 
@@ -247,7 +251,7 @@ tcFamInstDecl (L loc decl)
     recoverM (returnM Nothing)                 $
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
-    do { -- type families require -ftype-families and can't be in an
+    do { -- type families require -XTypeFamilies and can't be in an
         -- hs-boot file
        ; type_families <- doptM Opt_TypeFamilies
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
@@ -332,8 +336,9 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 
          -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; let ex_ok = True      -- Existentials ok for type families!
        ; tycon <- fixM (\ tycon -> do 
-            { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
+            { data_cons <- mappM (addLocM (tcConDecl unbox_strict ex_ok tycon t_tvs))
                                  k_cons
             ; tc_rhs <-
                 case new_or_data of
@@ -666,14 +671,14 @@ tcTyClDecl1 _calc_isrec
   { traceTc (text "type family: " <+> ppr tc_name) 
   ; idx_tys <- doptM Opt_TypeFamilies
 
-       -- Check that we don't use families without -ftype-families
+       -- Check that we don't use families without -XTypeFamilies
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing
   ; return [ATyCon tycon]
   }
 
-  -- "newtype family" or "data family" declaration
+  -- "data family" declaration
 tcTyClDecl1 _calc_isrec 
   (TyFamily {tcdFlavour = DataFamily, 
             tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
@@ -684,7 +689,7 @@ tcTyClDecl1 _calc_isrec
 
   ; idx_tys <- doptM Opt_TypeFamilies
 
-       -- Check that we don't use families without -ftype-families
+       -- Check that we don't use families without -XTypeFamilies
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
@@ -693,6 +698,7 @@ tcTyClDecl1 _calc_isrec
   }
 
   -- "newtype" and "data"
+  -- NB: not used for newtype/data instances (whether associated or not)
 tcTyClDecl1 calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
           tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
@@ -704,8 +710,10 @@ tcTyClDecl1 calc_isrec
   ; unbox_strict <- doptM Opt_UnboxStrictFields
   ; empty_data_decls <- doptM Opt_EmptyDataDecls
   ; kind_signatures <- doptM Opt_KindSignatures
+  ; existential_ok <- doptM Opt_ExistentialQuantification
   ; gadt_ok      <- doptM Opt_GADTs
   ; is_boot     <- tcIsHsBoot  -- Are we compiling an hs-boot file?
+  ; let ex_ok = existential_ok || gadt_ok      -- Data cons can have existential context
 
        -- Check that we don't use GADT syntax in H98 world
   ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
@@ -726,7 +734,7 @@ tcTyClDecl1 calc_isrec
            (newtypeConError tc_name (length cons))
 
   ; tycon <- fixM (\ tycon -> do 
-       { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon final_tvs)) 
+       { data_cons <- mappM (addLocM (tcConDecl unbox_strict ex_ok tycon final_tvs)) 
                             cons
        ; tc_rhs <-
            if null cons && is_boot     -- In a hs-boot file, empty cons means
@@ -755,6 +763,8 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
+            -- NB: 'ats' only contains "type family" and "data family"
+            --     declarations as well as type family defaults
   ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats)
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
@@ -795,14 +805,17 @@ tcTyClDecl1 calc_isrec
 
 -----------------------------------
 tcConDecl :: Bool              -- True <=> -funbox-strict_fields
+         -> Bool               -- True <=> -XExistentialQuantificaton or -XGADTs
          -> TyCon -> [TyVar] 
          -> ConDecl Name 
          -> TcM DataCon
 
-tcConDecl unbox_strict tycon tc_tvs    -- Data types
+tcConDecl unbox_strict existential_ok tycon tc_tvs     -- Data types
          (ConDecl name _ tvs ctxt details res_ty _)
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
+    ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
+             (badExistential name)
     ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
     ; let 
        -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames
@@ -1199,6 +1212,11 @@ badGadtDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
         , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ]
 
+badExistential con_name
+  = hang (ptext SLIT("Data constructor") <+> quotes (ppr con_name) <+>
+               ptext SLIT("has existential type variables, or a context, or both"))
+       2 (parens $ ptext SLIT("Use -XExistentialQuantification or -XGADTs to allow this"))
+
 badStupidTheta tc_name
   = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)