[project @ 2000-07-11 16:24:57 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 034c011..5638cf1 100644 (file)
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv.
 \begin{code}
 module TcInstUtil (
        InstInfo(..),
-       buildInstanceEnvs,
+       buildInstanceEnv,
        classDataCon
     ) where
 
@@ -18,21 +18,20 @@ import RnHsSyn              ( RenamedMonoBinds, RenamedSig )
 
 import CmdLineOpts     ( opt_AllowOverlappingInstances )
 import TcMonad
-import Inst            ( InstanceMapper )
-
+import TcEnv           ( InstEnv, emptyInstEnv, addToInstEnv )
 import Bag             ( bagToList, Bag )
-import Class           ( ClassInstEnv, Class )
-import Var             ( TyVar, Id )
-import SpecEnv         ( emptySpecEnv, addToSpecEnv )
+import Class           ( Class )
+import Var             ( TyVar, Id, idName )
 import Maybes          ( MaybeErr(..), mkLookupFunDef )
-import Name            ( getSrcLoc )
+import Name            ( getSrcLoc, nameModule, isLocallyDefined )
 import SrcLoc          ( SrcLoc )
-import Type            ( ThetaType, Type )
+import Type            ( Type, ClassContext )
 import PprType         ( pprConstraint )
 import Class           ( classTyCon )
 import DataCon         ( DataCon )
 import TyCon           ( tyConDataCons )
-import Util            ( equivClasses, assertPanic )
+import Unique          ( Unique, getUnique )
+import Util            ( equivClassesByUniq )
 import Outputable
 \end{code}
 
@@ -44,7 +43,7 @@ data InstInfo
       Class            -- Class, k
       [TyVar]          -- Type variables, tvs
       [Type]           -- The types at which the class is being instantiated
-      ThetaType                -- inst_decl_theta: the original context, c, from the
+      ClassContext     -- inst_decl_theta: the original context, c, from the
                        --   instance declaration.  It constrains (some of)
                        --   the TyVars above
       Id               -- The dfun id
@@ -76,33 +75,9 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
 %************************************************************************
 
 \begin{code}
-buildInstanceEnvs :: Bag InstInfo
-                 -> NF_TcM s InstanceMapper
-
-buildInstanceEnvs info
-  = let
-       icmp :: InstInfo -> InstInfo -> Ordering
-       (InstInfo c1 _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _)
-         = c1 `compare` c2
-
-       info_by_class = equivClasses icmp (bagToList info)
-    in
-    mapNF_Tc buildInstanceEnv info_by_class    `thenNF_Tc` \ inst_env_entries ->
-    let
-       class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv
-    in
-    returnNF_Tc class_lookup_fn
-\end{code}
+buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
 
-\begin{code}
-buildInstanceEnv :: [InstInfo]         -- Non-empty, and all for same class
-                -> NF_TcM s (Class, ClassInstEnv)
-
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
-  = foldrNF_Tc addClassInstance
-           emptySpecEnv
-           inst_infos                          `thenNF_Tc` \ class_inst_env ->
-    returnNF_Tc (clas, class_inst_env)
+buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
 \end{code}
 
 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
@@ -112,29 +87,32 @@ about any overlap with an existing instance.
 \begin{code}
 addClassInstance
     :: InstInfo
-    -> ClassInstEnv
-    -> NF_TcM s ClassInstEnv
+    -> InstEnv
+    -> NF_TcM s InstEnv
 
 addClassInstance 
     (InstInfo clas inst_tyvars inst_tys _
              dfun_id _ src_loc _)
-    class_inst_env
+    inst_env
   =    -- Add the instance to the class's instance environment
-    case addToSpecEnv opt_AllowOverlappingInstances 
-                     class_inst_env inst_tyvars inst_tys dfun_id of
-       Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc) 
-                                                              (ty', getSrcLoc dfun_id'))
+    case addToInstEnv opt_AllowOverlappingInstances 
+                     inst_env clas inst_tyvars inst_tys dfun_id of
+       Failed (tys', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, dfun_id) 
+                                                               (tys',     dfun_id'))
                                                `thenNF_Tc_`
-                                    returnNF_Tc class_inst_env
+                                    returnNF_Tc inst_env
 
-       Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
+       Succeeded inst_env' -> returnNF_Tc inst_env'
 \end{code}
 
 \begin{code}
-dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
+dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
        -- Overlapping/duplicate instances for given class; msg could be more glamourous
   = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
          4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
-                nest 4 (sep [ptext SLIT("at")  <+> ppr locn1,
-                             ptext SLIT("and") <+> ppr locn2])])
+                nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
+  where
+    ppr_loc dfun
+       | isLocallyDefined dfun = ptext SLIT("defined at")           <+> ppr (getSrcLoc dfun)
+       | otherwise             = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
 \end{code}