Check that AT instance is in a class

Mon Sep 18 19:16:40 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Check that AT instance is in a class
  Sat Aug 26 21:49:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Check that AT instance is in a class

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 2a51661..e12f234 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -28,9 +28,10 @@ import TcHsType              ( kcHsSigType, tcHsKindedType )
 import TcUnify         ( checkSigTyVars )
 import TcSimplify      ( tcSimplifySuperClasses )
 import Type            ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
-                          splitFunTys, TyThing )
+                          splitFunTys, TyThing(ATyCon) )
 import Coercion         ( mkSymCoercion )
-import TyCon            ( TyCon, newTyConCo, tyConTyVars )
+import TyCon            ( TyCon, tyConName, newTyConCo, tyConTyVars,
+                         isAssocTyCon, tyConFamInst_maybe )
 import DataCon         ( classDataCon, dataConTyCon, dataConInstArgTys )
 import Class           ( classBigSig )
 import Var             ( TyVar, Id, idName, idType, tyVarKind )
@@ -38,7 +39,8 @@ import Id               ( mkSysLocal )
 import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
 import MkId            ( mkDictFunId )
 import Name            ( Name, getSrcLoc )
-import Maybe           ( catMaybes )
+import Maybe           ( isNothing, fromJust, catMaybes )
+import Monad           ( when )
 import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps      ( minusList )
 import Outputable
@@ -147,8 +149,8 @@ tcInstDecls1 tycl_decls inst_decls
                -- (1) Do the ordinary instance declarations and instances of
                --     indexed types
        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
-       ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
-       ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
+       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
+       ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
 
        ; let { (local_infos,
                local_tycons)    = unzip local_info_tycons
@@ -186,6 +188,27 @@ tcInstDecls1 tycl_decls inst_decls
                  generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
                  deriv_binds) 
     }}}}}
+  where
+    -- Make sure that toplevel type instance are not for associated types.
+    -- !!!TODO: Need to perform this check for the InstInfo structures of type
+    --         functions, too.
+    tcIdxTyInstDeclTL ldecl@(L loc decl) =
+      do { (info, tything) <- tcIdxTyInstDecl ldecl
+        ; setSrcSpan loc $
+            when (isAssocFamily tything) $
+              addErr $ assocInClassErr (tcdName decl)
+        ; return (info, tything)
+        }
+    isAssocFamily (Just (ATyCon tycon)) =
+      case tyConFamInst_maybe tycon of
+        Nothing       -> panic "isAssocFamily: no family?!?"
+       Just (fam, _) -> isAssocTyCon fam
+    isAssocFamily (Just _            ) = panic "isAssocFamily: no tycon?!?"
+    isAssocFamily Nothing               = False
+
+assocInClassErr name = 
+  ptext SLIT("Associated type must be inside class instance") <+> 
+  quotes (ppr name)
 
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 7f6baf8..0934919 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -51,7 +51,7 @@ import TyCon          ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
                          tyConDataCons, mkForeignTyCon, isProductTyCon,
                          isRecursiveTyCon, isOpenTyCon,
                          tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
-                          isNewTyCon, tyConKind )
+                          isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
 import DataCon         ( DataCon, dataConUserType, dataConName, 
                          dataConFieldLabels, dataConTyCon, dataConAllTyVars,
                          dataConFieldType, dataConResTys )
@@ -620,7 +620,7 @@ tcTyClDecl1 _calc_isrec
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name
 
-  ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 
   -- kind signature for an indexed data type
@@ -707,7 +707,7 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
-  ; let ats' = concat atss
+  ; let ats' = map makeTyThingAssoc . concat $ atss
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
                let     -- This little knot is just so we can get
@@ -726,6 +726,8 @@ tcTyClDecl1 calc_isrec
     tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
                                ; tvs2' <- mappM tcLookupTyVar tvs2 ;
                                ; return (tvs1', tvs2') }
+    makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon)
+    makeTyThingAssoc _             = panic "makeTyThingAssoc"
 
 
 tcTyClDecl1 calc_isrec 

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 5ded0a8..40cfa06 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -15,7 +15,8 @@ module TyCon(
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
+       makeTyConAssoc,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,
@@ -94,11 +95,14 @@ data TyCon
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,
-       
+
        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon
                                        -- But not over the data constructors
+
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+       
        algTcSelIds :: [Id],            -- Its record selectors (empty if none)
 
        algTcGadtSyntax  :: Bool,       -- True <=> the data type was declared using GADT syntax
@@ -133,13 +137,14 @@ data TyCon
     }
 
   | SynTyCon {
-       tyConUnique :: Unique,
-       tyConName   :: Name,
-       tyConKind   :: Kind,
-       tyConArity  :: Arity,
-
-       tyConTyVars :: [TyVar],         -- Bound tyvars
-       synTcRhs    :: SynTyConRhs      -- Expanded type in here
+       tyConUnique  :: Unique,
+       tyConName    :: Name,
+       tyConKind    :: Kind,
+       tyConArity   :: Arity,
+
+       tyConTyVars  :: [TyVar],        -- Bound tyvars
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+       synTcRhs     :: SynTyConRhs     -- Expanded type in here
     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
@@ -399,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
        tyConKind        = kind,
        tyConArity       = length tyvars,
        tyConTyVars      = tyvars,
+       tyConIsAssoc     = False,
        algTcStupidTheta = stupid,
        algTcRhs         = rhs,
        algTcSelIds      = sel_ids,
@@ -468,6 +474,7 @@ mkSynTyCon name kind tyvars rhs
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
+       tyConIsAssoc = False,
        synTcRhs = rhs
     }
 
@@ -573,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _                                     = False
 
+isAssocTyCon :: TyCon -> Bool
+isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon _                                     = False
+
+makeTyConAssoc :: TyCon -> TyCon
+makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
+
 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it