Fixed two data family bugs

Mon Sep 18 19:06:51 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fixed two data family bugs
  Mon Aug 21 15:16:16 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fixed two data family bugs
    - Too liberal pattern matching in `tcTyClDecl1'
    - Open TyCons must always be exposed (ie, never be turned into abstract tycons
      during tidying)

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 7b98bcd..16df566 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -39,7 +39,8 @@ import Type           ( tidyTopType )
 import TcType          ( isFFITy )
 import DataCon         ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
 import TyCon           ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, 
 import TcType          ( isFFITy )
 import DataCon         ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
 import TyCon           ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, 

-                         newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon )
+                         newTyConRep, tyConSelIds, isAlgTyCon,
+                         isEnumerationTyCon, isOpenTyCon )

 import Class           ( classSelIds )
 import Module          ( Module )
 import HscTypes                ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
 import Class           ( classSelIds )
 import Module          ( Module )
 import HscTypes                ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),

@@ -351,6 +352,8 @@ mustExposeTyCon exports tc
   | isEnumerationTyCon tc      -- For an enumeration, exposing the constructors
   = True                       -- won't lead to the need for further exposure
                                -- (This includes data types with no constructors.)
   | isEnumerationTyCon tc      -- For an enumeration, exposing the constructors
   = True                       -- won't lead to the need for further exposure
                                -- (This includes data types with no constructors.)

+  | isOpenTyCon tc             -- open type family
+  = True

   | otherwise                  -- Newtype, datatype
   = any exported_con (tyConDataCons tc)
        -- Expose rep if any datacon or field is exported
   | otherwise                  -- Newtype, datatype
   = any exported_con (tyConDataCons tc)
        -- Expose rep if any datacon or field is exported

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c0c1f59..ddccb2f 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -615,7 +615,8 @@ tcTyClDecl calc_isrec decl
 tcTyClDecl1 _calc_isrec 
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
 tcTyClDecl1 _calc_isrec 
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 

-  { gla_exts <- doptM Opt_GlasgowExts
+  { traceTc (text "type family: " <+> ppr tc_name) 
+  ; gla_exts <- doptM Opt_GlasgowExts

 
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name
 
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name

@@ -626,9 +627,10 @@ tcTyClDecl1 _calc_isrec
   -- kind signature for an indexed data type
 tcTyClDecl1 _calc_isrec 
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
   -- kind signature for an indexed data type
 tcTyClDecl1 _calc_isrec 
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,

-          tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []})
+          tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []})

   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   = tcTyVarBndrs tvs  $ \ tvs' -> do 

-  { extra_tvs <- tcDataKindSig mb_ksig
+  { traceTc (text "data/newtype family: " <+> ppr tc_name) 
+  ; extra_tvs <- tcDataKindSig (Just ksig)

   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name