Basic set up for global family instance environment
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 18:50:19 +0000 (18:50 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 18:50:19 +0000 (18:50 +0000)
Mon Sep 18 19:52:34 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Basic set up for global family instance environment
  Fri Sep 15 15:20:44 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Basic set up for global family instance environment

compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcType.lhs

index e186b36..6135ca2 100644 (file)
@@ -22,6 +22,8 @@ import TcType         ( TcType, mkClassPred, tcSplitSigmaTy,
 import Inst            ( newDictBndr, newDictBndrs, instToId, showLIE, 
                          getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv         ( mkLocalInstance, instanceDFunId )
 import Inst            ( newDictBndr, newDictBndrs, instToId, showLIE, 
                          getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv         ( mkLocalInstance, instanceDFunId )
+import FamInst         ( tcExtendLocalFamInstEnv )
+import FamInstEnv      ( extractFamInsts )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( InstInfo(..), InstBindings(..), 
                          newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( InstInfo(..), InstBindings(..), 
                          newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
@@ -160,22 +162,19 @@ tcInstDecls1 tycl_decls inst_decls
                --     types 
        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
                --     types 
        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
-       ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
+       ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 
        ; let { (local_infos,
 
        ; let { (local_infos,
-               local_tycons)    = unzip local_info_tycons
-            ; (idxty_infos, 
-               idxty_tycons)    = unzip idxty_info_tycons
-            ; local_idxty_info  = concat local_infos ++ catMaybes idxty_infos
-            ; local_idxty_tycon = concat local_tycons ++ 
-                                  catMaybes idxty_tycons
-            ; clas_decls        = filter (isClassDecl.unLoc) tycl_decls 
-            ; implicit_things   = concatMap implicitTyThings local_idxty_tycon
+               at_tycons)     = unzip local_info_tycons
+            ; local_info      = concat local_infos
+            ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
+            ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls 
+            ; implicit_things = concatMap implicitTyThings at_idx_tycon
             }
 
             }
 
-               -- (2) Add the tycons of associated types and their implicit
+               -- (2) Add the tycons of indexed types and their implicit
                --     tythings to the global environment
                --     tythings to the global environment
-       ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
+       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
 
                -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
 
                -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
@@ -184,8 +183,10 @@ tcInstDecls1 tycl_decls inst_decls
                -- of 
                --   a) local instance decls
                --   b) generic instances
                -- of 
                --   a) local instance decls
                --   b) generic instances
-       ; addInsts local_idxty_info  $ do {
-       ; addInsts generic_inst_info $ do {
+               --   c) local family instance decls
+       ; addInsts local_info         $ do {
+       ; addInsts generic_inst_info  $ do {
+       ; addFamInsts at_idx_tycon    $ do {
 
                -- (4) Compute instances from "deriving" clauses; 
                -- This stuff computes a context for the derived instance
 
                -- (4) Compute instances from "deriving" clauses; 
                -- This stuff computes a context for the derived instance
@@ -195,19 +196,19 @@ tcInstDecls1 tycl_decls inst_decls
 
        ; gbl_env <- getGblEnv
        ; returnM (gbl_env, 
 
        ; gbl_env <- getGblEnv
        ; returnM (gbl_env, 
-                 generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
+                 generic_inst_info ++ deriv_inst_info ++ local_info,
                  deriv_binds) 
                  deriv_binds) 
-    }}}}}
+    }}}}}}
   where
     -- Make sure that toplevel type instance are not for associated types.
   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.
+    -- !!!TODO: Need to perform this check for the TyThing of type functions,
+    --         too.
     tcIdxTyInstDeclTL ldecl@(L loc decl) =
     tcIdxTyInstDeclTL ldecl@(L loc decl) =
-      do { (info, tything) <- tcIdxTyInstDecl ldecl
+      do { tything <- tcIdxTyInstDecl ldecl
         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)
         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)
-        ; return (info, tything)
+        ; return tything
         }
     isAssocFamily (Just (ATyCon tycon)) =
       case tyConFamInst_maybe tycon of
         }
     isAssocFamily (Just (ATyCon tycon)) =
       case tyConFamInst_maybe tycon of
@@ -223,6 +224,10 @@ assocInClassErr name =
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
+addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts tycons thing_inside
+  = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside
 \end{code} 
 
 \begin{code}
 \end{code} 
 
 \begin{code}
@@ -249,13 +254,13 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
        ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
        
        -- Next, process any associated types.
        ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
        
        -- Next, process any associated types.
-       ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
+       ; idx_tycons <- mappM tcIdxTyInstDecl ats
 
        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
        ; checkValidInstance tyvars theta clas inst_tys
        ; checkValidAndMissingATs clas (tyvars, inst_tys) 
 
        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
        ; checkValidInstance tyvars theta clas inst_tys
        ; checkValidAndMissingATs clas (tyvars, inst_tys) 
-                                 (zip ats idxty_info_tycons)
+                                 (zip ats idx_tycons)
 
        -- Finally, construct the Core representation of the instance.
        -- (This no longer includes the associated types.)
 
        -- Finally, construct the Core representation of the instance.
        -- (This no longer includes the associated types.)
@@ -263,13 +268,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
        ; overlap_flag <- getOverlapFlag
        ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
              ispec          = mkLocalInstance dfun overlap_flag
        ; overlap_flag <- getOverlapFlag
        ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
              ispec          = mkLocalInstance dfun overlap_flag
-             (idxty_infos, 
-              idxty_tycons) = unzip idxty_info_tycons
 
        ; return ([InstInfo { iSpec  = ispec, 
 
        ; return ([InstInfo { iSpec  = ispec, 
-                             iBinds = VanillaInst binds uprags }] ++
-                  catMaybes idxty_infos,
-                 catMaybes idxty_tycons)
+                             iBinds = VanillaInst binds uprags }],
+                 catMaybes idx_tycons)
         }
   where
     -- We pass in the source form and the type checked form of the ATs.  We
         }
   where
     -- We pass in the source form and the type checked form of the ATs.  We
@@ -278,8 +280,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
     checkValidAndMissingATs :: Class
                            -> ([TyVar], [TcType])     -- instance types
                            -> [(LTyClDecl Name,       -- source form of AT
     checkValidAndMissingATs :: Class
                            -> ([TyVar], [TcType])     -- instance types
                            -> [(LTyClDecl Name,       -- source form of AT
-                                (Maybe InstInfo,      -- Core form for type
-                                 Maybe TyThing))]     -- Core form for data
+                                Maybe TyThing)]       -- Core form of AT
                            -> TcM ()
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
                            -> TcM ()
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
@@ -297,11 +298,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
           ; mapM_ (checkIndexes clas inst_tys) ats
           }
 
           ; mapM_ (checkIndexes clas inst_tys) ats
           }
 
-    checkIndexes _    _        (hsAT, (Nothing, Nothing))              = 
+    checkIndexes _    _        (hsAT, Nothing)             = 
       return ()           -- skip, we already had an error here
       return ()           -- skip, we already had an error here
-    checkIndexes clas inst_tys (hsAT, (Just _  , Nothing            )) = 
-      panic "do impl for AT syns"  -- !!!TODO: also call checkIndexes'
-    checkIndexes clas inst_tys (hsAT, (Nothing , Just (ATyCon tycon))) = 
+    checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = 
+-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
       checkIndexes' clas inst_tys hsAT 
                    (tyConTyVars tycon, 
                     snd . fromJust . tyConFamInst_maybe $ tycon)
       checkIndexes' clas inst_tys hsAT 
                    (tyConTyVars tycon, 
                     snd . fromJust . tyConFamInst_maybe $ tycon)
index abe8745..9da9dc9 100644 (file)
@@ -35,6 +35,7 @@ import Type           ( Type )
 import TcType          ( tcIsTyVarTy, tcGetTyVar )
 import NameEnv         ( extendNameEnvList, nameEnvElts )
 import InstEnv         ( emptyInstEnv )
 import TcType          ( tcIsTyVarTy, tcGetTyVar )
 import NameEnv         ( extendNameEnvList, nameEnvElts )
 import InstEnv         ( emptyInstEnv )
+import FamInstEnv      ( emptyFamInstEnv )
 
 import Var             ( setTyVarName )
 import VarSet          ( emptyVarSet )
 
 import Var             ( setTyVarName )
 import VarSet          ( emptyVarSet )
@@ -102,6 +103,7 @@ initTc hsc_env hsc_src mod do_this
                tcg_type_env = hsc_global_type_env hsc_env,
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
                tcg_type_env = hsc_global_type_env hsc_env,
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
+               tcg_fam_inst_env  = emptyFamInstEnv,
                tcg_inst_uses = dfuns_var,
                tcg_th_used   = th_var,
                tcg_exports  = emptyNameSet,
                tcg_inst_uses = dfuns_var,
                tcg_th_used   = th_var,
                tcg_exports  = emptyNameSet,
index f66abdc..30c922d 100644 (file)
@@ -51,8 +51,10 @@ import HscTypes              ( FixityEnv,
 import Packages                ( PackageId )
 import Type            ( Type, pprTyThingCategory )
 import TcType          ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
 import Packages                ( PackageId )
 import Type            ( Type, pprTyThingCategory )
 import TcType          ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
-                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
+                         TcPredType, TcKind, tcCmpPred, tcCmpType,
+                         tcCmpTypes, pprSkolInfo )
 import InstEnv         ( Instance, InstEnv )
 import InstEnv         ( Instance, InstEnv )
+import FamInstEnv      ( FamInst, FamInstEnv )
 import IOEnv
 import RdrName         ( GlobalRdrEnv, LocalRdrEnv )
 import Name            ( Name )
 import IOEnv
 import RdrName         ( GlobalRdrEnv, LocalRdrEnv )
 import Name            ( Name )
@@ -153,8 +155,11 @@ data TcGblEnv
                -- bound in this module when dealing with hi-boot recursions
                -- Updated at intervals (e.g. after dealing with types and classes)
        
                -- bound in this module when dealing with hi-boot recursions
                -- Updated at intervals (e.g. after dealing with types and classes)
        
-       tcg_inst_env :: InstEnv,        -- Instance envt for *home-package* modules
-                                       -- Includes the dfuns in tcg_insts
+       tcg_inst_env     :: InstEnv,    -- Instance envt for *home-package* 
+                                       -- modules; Includes the dfuns in 
+                                       -- tcg_insts
+       tcg_fam_inst_env :: FamInstEnv, -- Ditto for family instances
+
                -- Now a bunch of things about this module that are simply 
                -- accumulated, but never consulted until the end.  
                -- Nevertheless, it's convenient to accumulate them along 
                -- Now a bunch of things about this module that are simply 
                -- accumulated, but never consulted until the end.  
                -- Nevertheless, it's convenient to accumulate them along 
index 0c0c93a..3c25a7f 100644 (file)
@@ -27,8 +27,7 @@ import TcEnv          ( TyThing(..),
                          tcLookupLocated, tcLookupLocatedGlobal, 
                          tcExtendGlobalEnv, tcExtendKindEnv,
                          tcExtendKindEnvTvs, newFamInstTyConName,
                          tcLookupLocated, tcLookupLocatedGlobal, 
                          tcExtendGlobalEnv, tcExtendKindEnv,
                          tcExtendKindEnvTvs, newFamInstTyConName,
-                         tcExtendRecEnv, tcLookupTyVar, InstInfo,
-                         tcLookupLocatedTyCon )
+                         tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon )
 import TcTyDecls       ( calcRecFlags, calcClassCycles, calcSynCycles )
 import TcClassDcl      ( tcClassSigs, tcAddDeclCtxt )
 import TcHsType                ( kcHsTyVars, kcHsLiftedSigType, kcHsType, 
 import TcTyDecls       ( calcRecFlags, calcClassCycles, calcSynCycles )
 import TcClassDcl      ( tcClassSigs, tcAddDeclCtxt )
 import TcHsType                ( kcHsTyVars, kcHsLiftedSigType, kcHsType, 
@@ -260,11 +259,10 @@ they share a lot of kinding and type checking code with ordinary algebraic
 data types (and GADTs).
 
 \begin{code}
 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
 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 -findexed-types and can't be in an
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
     do { -- indexed data types require -findexed-types and can't be in an
@@ -278,8 +276,7 @@ tcIdxTyInstDecl (L loc decl)
        ; tcIdxTyInstDecl1 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 ->
 
 tcIdxTyInstDecl1 (decl@TySynonym {})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
@@ -295,9 +292,8 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
        ; 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
          -- !!!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,
        }}
       
 tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
@@ -350,7 +346,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             })
 
          -- construct result
             })
 
          -- construct result
-       ; return (Nothing, Just (ATyCon tycon))
+       ; return $ Just (ATyCon tycon)
        }}
        where
         h98_syntax = case cons of      -- All constructors have same shape
        }}
        where
         h98_syntax = case cons of      -- All constructors have same shape
index a53c9ed..94ea3f9 100644 (file)
@@ -344,6 +344,7 @@ data SkolemInfo
        -- The rest are for non-scoped skolems
   | ClsSkol Class      -- Bound at a class decl
   | InstSkol Id                -- Bound at an instance decl
        -- The rest are for non-scoped skolems
   | ClsSkol Class      -- Bound at a class decl
   | InstSkol Id                -- Bound at an instance decl
+  | FamInstSkol TyCon  -- Bound at a family instance decl
   | PatSkol DataCon    -- An existential type variable bound by a pattern for
            SrcSpan     -- a data constructor with an existential type. E.g.
                        --      data T = forall a. Eq a => MkT a
   | PatSkol DataCon    -- An existential type variable bound by a pattern for
            SrcSpan     -- a data constructor with an existential type. E.g.
                        --      data T = forall a. Eq a => MkT a
@@ -486,8 +487,13 @@ pprSkolTvBinding tv
 pprSkolInfo :: SkolemInfo -> SDoc
 pprSkolInfo (SigSkol ctxt)   = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
 pprSkolInfo (ClsSkol cls)    = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
 pprSkolInfo :: SkolemInfo -> SDoc
 pprSkolInfo (SigSkol ctxt)   = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
 pprSkolInfo (ClsSkol cls)    = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo (InstSkol df)    = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
-pprSkolInfo (ArrowSkol loc)  = ptext SLIT("is bound by the arrow form at") <+> ppr loc
+pprSkolInfo (InstSkol df)    = 
+  ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
+pprSkolInfo (FamInstSkol tc) = 
+  ptext SLIT("is bound by the family instance declaration at") <+> 
+  ppr (getSrcLoc tc)
+pprSkolInfo (ArrowSkol loc)  = 
+  ptext SLIT("is bound by the arrow form at") <+> ppr loc
 pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
                                    nest 2 (ptext SLIT("at") <+> ppr loc)]
 pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), 
 pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
                                    nest 2 (ptext SLIT("at") <+> ppr loc)]
 pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"),