Check that AT instance is in a class

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c0c1f59..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 )
@@ -311,7 +311,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 
        ; tycon <- fixM (\ tycon -> do 
             { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
-                                             tycon t_tvs (Just t_typats)))
+                                             tycon t_tvs))
                                  k_cons
             ; tc_rhs <-
                 case new_or_data of
@@ -320,7 +320,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                            ASSERT( isSingleton data_cons )
                            mkNewTyConRhs tc_name tycon (head data_cons)
             ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
-                            False h98_syntax (Just family)
+                            False h98_syntax (Just (family, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -329,7 +329,6 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             })
 
          -- construct result
-        -- !!!TODO: missing eq axiom
        ; return (Nothing, Just (ATyCon tycon))
        }}
        where
@@ -615,20 +614,22 @@ tcTyClDecl calc_isrec decl
 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
 
-  ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 
   -- 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 
-  { 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
@@ -677,7 +678,7 @@ tcTyClDecl1 calc_isrec
 
   ; tycon <- fixM (\ tycon -> do 
        { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
-                                                tycon final_tvs Nothing)) 
+                                                tycon final_tvs)) 
                             cons
        ; tc_rhs <-
            if null cons && is_boot     -- In a hs-boot file, empty cons means
@@ -706,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
@@ -725,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 
@@ -735,11 +738,10 @@ tcTyClDecl1 calc_isrec
 tcConDecl :: Bool              -- True <=> -funbox-strict_fields
          -> NewOrData 
          -> TyCon -> [TyVar] 
-         -> Maybe [Type]       -- Just ts <=> type patterns of instance type
          -> ConDecl Name 
          -> TcM DataCon
 
-tcConDecl unbox_strict NewType tycon tc_tvs mb_typats  -- Newtypes
+tcConDecl unbox_strict NewType tycon tc_tvs    -- Newtypes
          (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
   = do { let tc_datacon field_lbls arg_ty
                = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
@@ -749,8 +751,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats       -- Newtypes
                                    tc_tvs []  -- No existentials
                                    [] []      -- No equalities, predicates
                                    [arg_ty']
-                                   tycon 
-                                   mb_typats}
+                                   tycon }
 
                -- Check that a newtype has no existential stuff
        ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
@@ -763,7 +764,7 @@ tcConDecl unbox_strict NewType tycon tc_tvs mb_typats       -- Newtypes
                        -- Check that the constructor has exactly one field
        }
 
-tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types
+tcConDecl unbox_strict DataType tycon tc_tvs   -- Data types
          (ConDecl name _ tvs ctxt details res_ty)
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
@@ -776,8 +777,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs mb_typats      -- Data types
                    (argStrictness unbox_strict tycon bangs arg_tys)
                    (map unLoc field_lbls)
                    univ_tvs ex_tvs eq_preds ctxt' arg_tys
-                   data_tc 
-                   mb_typats}
+                   data_tc }
                -- 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.