%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcInstUtil]{Utilities for typechecking instance declarations}
+\section[InstEnv]{Utilities for typechecking instance declarations}
The bits common to TcInstDcls and TcDeriv.
\begin{code}
-module TcInstUtil (
- InstInfo(..), pprInstInfo,
- simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon,
+module InstEnv (
+ DFunId, ClsInstEnv, InstEnv,
- -- Instance environment
- InstEnv, emptyInstEnv, extendInstEnv,
+ emptyInstEnv, extendInstEnv,
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 )
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, splitTyConApp_maybe,
+ 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 )
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
+ (_,_,clas,[ty]) = splitDFunTy (idType dfun)
+ 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
\end{code}
%************************************************************************
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'
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)