Check category of type instances and some newtype family fixes

Mon Sep 18 19:23:39 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Check category of type instances and some newtype family fixes
  Thu Aug 31 16:54:14 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Check category of type instances and some newtype family fixes

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index e83d77f..278ffe8 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -51,7 +51,8 @@ import TyCon          ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
                          tyConDataCons, mkForeignTyCon, isProductTyCon,
                          isRecursiveTyCon, isOpenTyCon,
                          tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
-                          isNewTyCon, tyConKind, setTyConArgPoss ) 
+                          isNewTyCon, isDataTyCon, tyConKind, 
+                         setTyConArgPoss )
 import DataCon         ( DataCon, dataConUserType, dataConName, 
                          dataConFieldLabels, dataConTyCon, dataConAllTyVars,
                          dataConFieldType, dataConResTys )
@@ -61,12 +62,12 @@ import Name         ( Name, getSrcLoc )
 import Outputable
 import Maybe           ( isJust, fromJust, isNothing, catMaybes )
 import Maybes          ( expectJust )
+import Monad           ( unless )
 import Unify           ( tcMatchTys, tcMatchTyX )
 import Util            ( zipLazy, isSingleton, notNull, sortLe )
 import List            ( partition, elemIndex )
 import SrcLoc          ( Located(..), unLoc, getLoc, srcLocSpan )
 import ListSetOps      ( equivClasses, minusList )
-import List            ( delete )
 import Digraph         ( SCC(..) )
 import DynFlags                ( DynFlag( Opt_GlasgowExts, Opt_Generics, 
                                        Opt_UnboxStrictFields ) )
@@ -270,8 +271,12 @@ tcIdxTyInstDecl1 :: TyClDecl Name
                 -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
 
 tcIdxTyInstDecl1 (decl@TySynonym {})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind _ ->
-    do { -- (1) kind check the right hand side of the type equation
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+    do { -- check that the family declaration is for a synonym
+        unless (isSynTyCon family) $
+          addErr (wrongKindOfFamily family)
+
+       ; -- (1) kind check the right hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
          -- (2) type check type equation
@@ -287,7 +292,12 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
 tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                               tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
-    do { -- (1) kind check the data declaration as usual
+    do { -- check that the family declaration is for the right kind
+        unless (new_or_data == NewType  && isNewTyCon  family ||
+                new_or_data == DataType && isDataTyCon family) $
+          addErr (wrongKindOfFamily family)
+
+       ; -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
        ; let k_ctxt = tcdCtxt k_decl
             k_cons = tcdCons k_decl
@@ -1164,7 +1174,16 @@ tooFewParmsErr tc_name
   = ptext SLIT("Indexed type instance has too few parameters:") <+> 
     quotes (ppr tc_name)
 
-badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file")
+badBootTyIdxDeclErr = 
+  ptext SLIT("Illegal indexed type instance in hs-boot file")
+
+wrongKindOfFamily family =
+  ptext SLIT("Wrong category of type instance; declaration was for a") <+>
+  kindOfFamily
+  where
+    kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")
+                | isDataTyCon family = ptext SLIT("data type")
+                | isNewTyCon  family = ptext SLIT("newtype")
 
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 86d4a2b..f16d89e 100644 (file)
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -23,7 +23,8 @@ import Type           ( predTypeRep, tcView )
 import HscTypes                ( TyThing(..), ModDetails(..) )
 import TyCon            ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
                           isSynTyCon, isAlgTyCon, 
-                         tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
+                         tyConName, isNewTyCon, isProductTyCon, newTyConRhs,
+                         isOpenTyCon )
 import Class           ( classTyCon )
 import DataCon          ( dataConOrigArgTys )
 import Var              ( TyVar )
@@ -238,7 +239,8 @@ calcRecFlags boot_details tyclss
        -- rather less nice, so I'm not going to do that yet.
 
        --------------- Newtypes ----------------------
-    new_tycons = filter isNewTyCon all_tycons
+    new_tycons = filter isNewTyConAndNotOpen all_tycons
+    isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
     nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
     is_rec_nt tc = tyConName tc  `elemNameSet` nt_loop_breakers
        -- is_rec_nt is a locally-used helper function

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 15be3e2..d536f59 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -550,13 +550,15 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
        OpenNewTyCon  -> False
        NewTyCon {}   -> False
        AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True 
-isNewTyCon other                              = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+                                          OpenNewTyCon -> True
+                                          NewTyCon {}  -> True
+                                          _            -> False
+isNewTyCon other                       = False
 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
@@ -746,7 +748,10 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }})
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
 newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }})
+  = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
+  = Nothing
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 
 tyConPrimRep :: TyCon -> PrimRep

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index a7aeeec..b7f1a00 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -117,7 +117,8 @@ import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey,
                   ubxTupleKindTyConKey, argTypeKindTyConKey )
 import TyCon   ( TyCon, isRecursiveTyCon, isPrimTyCon,
                  isUnboxedTupleTyCon, isUnLiftedTyCon,
-                 isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
+                 isFunTyCon, isNewTyCon, isOpenTyCon, newTyConRep,
+                 newTyConRhs, 
                  isAlgTyCon, tyConArity, isSuperKindTyCon,
                  tcExpandTyCon_maybe, coreExpandTyCon_maybe,
                  tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
@@ -448,7 +449,7 @@ repType looks through
        (b) synonyms
        (c) predicates
        (d) usage annotations
-       (e) all newtypes, including recursive ones
+       (e) all newtypes, including recursive ones, but not newtype families
 It's useful in the back end.
 
 \begin{code}
@@ -457,7 +458,8 @@ repType :: Type -> Type
 repType ty | Just ty' <- coreView ty = repType ty'
 repType (ForAllTy _ ty)  = repType ty
 repType (TyConApp tc tys)
-  | isNewTyCon tc       = -- Recursive newtypes are opaque to coreView
+  | isNewTyCon tc &&
+    not (isOpenTyCon tc) = -- Recursive newtypes are opaque to coreView
                           -- but we must expand them here.  Sure to
                           -- be saturated because repType is only applied
                           -- to types of kind *