[project @ 2000-11-20 16:07:12 by simonpj]

[ghc-hetmet.git] / ghc / compiler / types / InstEnv.lhs

diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index d054178..8c5e678 100644 (file)
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -7,106 +7,62 @@ The bits common to TcInstDcls and TcDeriv.
 
 \begin{code}
 module InstEnv (
-       InstInfo(..), pprInstInfo,
-       simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon,
+       DFunId, ClsInstEnv, InstEnv,
 
-       -- Instance environment
-       InstEnv, emptyInstEnv, extendInstEnv,
+       emptyInstEnv, extendInstEnv, pprInstEnv,
        lookupInstEnv, InstLookupResult(..),
-       classInstEnv, classDataCon,
-
-       isLocalInst
+       classInstEnv, simpleDFunClassTyCon
     ) where
 
 #include "HsVersions.h"
 
-import RnHsSyn         ( RenamedMonoBinds, RenamedSig )
-
-import HscTypes                ( InstEnv, ClsInstEnv, DFunId )
 import Class           ( Class )
-import Var             ( TyVar, Id )
-import VarSet          ( unionVarSet, mkVarSet )
+import Var             ( Id )
+import VarSet          ( TyVarSet, unionVarSet, mkVarSet, varSetElems )
 import VarEnv          ( TyVarSubstEnv )
 import Maybes          ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
 import Name            ( getSrcLoc )
-import SrcLoc          ( SrcLoc )
-import Type            ( Type, ThetaType, splitTyConApp_maybe, 
-                         splitSigmaTy, splitDictTy,
-                         tyVarsOfTypes )
+import Type            ( Type, tyConAppTyCon, 
+                         splitSigmaTy, splitDFunTy, tyVarsOfTypes
+                       )
 import PprType         ( )
-import Class           ( classTyCon )
-import DataCon         ( DataCon )
-import TyCon           ( TyCon, tyConDataCons )
+import TyCon           ( TyCon )
 import Outputable
 import Unify           ( matchTys, unifyTyListsX )
-import UniqFM          ( lookupWithDefaultUFM, addToUFM, emptyUFM )
+import UniqFM          ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
 import Id              ( idType )
 import ErrUtils                ( Message )
 import CmdLineOpts
 \end{code}
 
 
-
 %************************************************************************
 %*                                                                     *
-\subsection{The InstInfo type}
+\subsection{The key types}
 %*                                                                     *
 %************************************************************************
 
-The InstInfo type summarises the information in an instance declaration
-
-    instance c => k (t tvs) where b
-
 \begin{code}
-data InstInfo
-  = InstInfo {
-      iClass :: Class,         -- Class, k
-      iTyVars :: [TyVar],      -- Type variables, tvs
-      iTys    :: [Type],       -- The types at which the class is being instantiated
-      iTheta  :: ThetaType,    -- inst_decl_theta: the original context, c, from the
-                               --   instance declaration.  It constrains (some of)
-                               --   the TyVars above
-      iLocal  :: Bool,         -- True <=> it's defined in this module
-      iDFunId :: DFunId,               -- The dfun id
-      iBinds  :: RenamedMonoBinds,     -- Bindings, b
-      iLoc    :: SrcLoc,               -- Source location assoc'd with this instance's defn
-      iPrags  :: [RenamedSig]          -- User pragmas recorded for generating specialised instances
-    }
-
-pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
-                        nest 4 (ppr (iBinds info))]
-
-simpleInstInfoTy :: InstInfo -> Type
-simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
-
-simpleInstInfoTyCon :: InstInfo -> TyCon
-  -- Gets the type constructor for a simple instance declaration,
-  -- i.e. one of the form      instance (...) => C (T a b c) where ...
-simpleInstInfoTyCon inst
-   = case splitTyConApp_maybe (simpleInstInfoTy inst) of 
-       Just (tycon, _) -> tycon
-
-isLocalInst :: InstInfo -> Bool
-isLocalInst info = iLocal info
-\end{code}
+type DFunId    = Id
 
+type InstEnv    = UniqFM ClsInstEnv            -- Maps Class to instances for that class
 
-A tiny function which doesn't belong anywhere else.
-It makes a nasty mutual-recursion knot if you put it in Class.
+type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
 
-\begin{code}
 simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
 simpleDFunClassTyCon dfun
   = (clas, tycon)
   where
-    (_,_,dict_ty) = splitSigmaTy (idType dfun)
-    (clas, [ty])  = splitDictTy  dict_ty
-    tycon        = case splitTyConApp_maybe ty of
-                       Just (tycon,_) -> tycon
-
-classDataCon :: Class -> DataCon
-classDataCon clas = case tyConDataCons (classTyCon clas) of
-                     (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr 
+    (_,_,clas,[ty]) = splitDFunTy (idType dfun)
+    tycon          = tyConAppTyCon ty 
+
+pprInstEnv :: InstEnv -> SDoc
+pprInstEnv env
+  = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> 
+          brackets (pprWithCommas ppr tys) <+> ppr dfun
+        | cls_inst_env <-  eltsUFM env
+        , (tyvars, tys, dfun) <- cls_inst_env
+        ]
 \end{code}                   
 
 %************************************************************************
@@ -329,7 +285,7 @@ extendInstEnv dflags env infos
     go env msgs []          = (env, msgs)
     go env msgs (dfun:dfuns) = case addToInstEnv dflags env dfun of
                                    Succeeded new_env -> go new_env msgs dfuns
-                                   Failed dfun'      -> go env (msg:msgs) infos
+                                   Failed dfun'      -> go env (msg:msgs) dfuns
                                                     where
                                                         msg = dupInstErr dfun dfun'
 
@@ -354,8 +310,7 @@ addToInstEnv dflags inst_env dfun_id
        Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
        
   where
-    (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id)
-    (clas, ins_tys)      = splitDictTy dict_ty
+    (ins_tvs, _, clas, ins_tys) = splitDFunTy (idType dfun_id)
 
     ins_tv_set = mkVarSet ins_tvs
     ins_item = (ins_tv_set, ins_tys, dfun_id)