Basic set up for global family instance environment

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index ce2846d..3c25a7f 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -27,7 +27,7 @@ import TcEnv          ( TyThing(..),
                          tcLookupLocated, tcLookupLocatedGlobal, 
                          tcExtendGlobalEnv, tcExtendKindEnv,
                          tcExtendKindEnvTvs, newFamInstTyConName,
-                         tcExtendRecEnv, tcLookupTyVar, InstInfo )
+                         tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon )
 import TcTyDecls       ( calcRecFlags, calcClassCycles, calcSynCycles )
 import TcClassDcl      ( tcClassSigs, tcAddDeclCtxt )
 import TcHsType                ( kcHsTyVars, kcHsLiftedSigType, kcHsType, 
@@ -72,7 +72,7 @@ import SrcLoc         ( Located(..), unLoc, getLoc, srcLocSpan,
 import ListSetOps      ( equivClasses, minusList )
 import Digraph         ( SCC(..) )
 import DynFlags                ( DynFlag( Opt_GlasgowExts, Opt_Generics, 
-                                       Opt_UnboxStrictFields ) )
+                                  Opt_UnboxStrictFields, Opt_IndexedTypes ) )
 \end{code}
 
 
@@ -259,16 +259,15 @@ they share a lot of kinding and type checking code with ordinary algebraic
 data types (and GADTs).
 
 \begin{code}
-tcIdxTyInstDecl :: LTyClDecl Name 
-               -> TcM (Maybe InstInfo, Maybe TyThing)  -- Nothing if error
+tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
 tcIdxTyInstDecl (L loc decl)
   =    -- Prime error recovery, set source location
-    recoverM (returnM (Nothing, Nothing))      $
+    recoverM (returnM Nothing)                 $
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
-    do { -- indexed data types require -fglasgow-exts and can't be in an
+    do { -- indexed data types require -findexed-types and can't be in an
         -- hs-boot file
-       ; gla_exts <- doptM Opt_GlasgowExts
+       ; gla_exts <- doptM Opt_IndexedTypes
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
        ; checkTc gla_exts      $ badIdxTyDecl (tcdLName decl)
        ; checkTc (not is_boot) $ badBootTyIdxDeclErr
@@ -277,8 +276,7 @@ tcIdxTyInstDecl (L loc decl)
        ; tcIdxTyInstDecl1 decl
        }
 
-tcIdxTyInstDecl1 :: TyClDecl Name 
-                -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
+tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
 
 tcIdxTyInstDecl1 (decl@TySynonym {})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
@@ -294,9 +292,8 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
-         -- construct type rewrite rule
          -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs
-       ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms
+       ; return Nothing     -- !!!TODO: need TyThing for indexed synonym
        }}
       
 tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
@@ -349,7 +346,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             })
 
          -- construct result
-       ; return (Nothing, Just (ATyCon tycon))
+       ; return $ Just (ATyCon tycon)
        }}
        where
         h98_syntax = case cons of      -- All constructors have same shape
@@ -371,10 +368,8 @@ kcIdxTyPats :: TyClDecl Name
            -> TcM a
 kcIdxTyPats decl thing_inside
   = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
-    do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
-       ; let { family = case tc_ty_thing of 
-                         AGlobal (ATyCon family) -> family
-             ; (kinds, resKind) = splitKindFunTys (tyConKind family)
+    do { family <- tcLookupLocatedTyCon (tcdLName decl)
+       ; let { (kinds, resKind) = splitKindFunTys (tyConKind family)
             ; hs_typats        = fromJust $ tcdTyPats decl }
 
          -- we may not have more parameters than the kind indicates
@@ -635,7 +630,7 @@ tcTyClDecl1 _calc_isrec
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "type family: " <+> ppr tc_name) 
-  ; gla_exts <- doptM Opt_GlasgowExts
+  ; gla_exts <- doptM Opt_IndexedTypes
 
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name
@@ -653,7 +648,7 @@ tcTyClDecl1 _calc_isrec
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
-  ; gla_exts <- doptM Opt_GlasgowExts
+  ; gla_exts <- doptM Opt_IndexedTypes
 
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name