[project @ 2000-11-21 09:30:16 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 54967ac..a49220d 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -33,7 +33,7 @@ import TcEnv          ( TcEnv, tcExtendGlobalValEnv,
                          InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, 
                          newDFunName, tcExtendTyVarEnv
                        )
-import InstEnv         ( InstEnv, extendInstEnv )
+import InstEnv         ( InstEnv, extendInstEnv, pprInstEnv )
 import TcMonoType      ( tcTyVars, tcHsSigType, kcHsSigType )
 import TcSimplify      ( tcSimplifyAndCheck )
 import TcType          ( zonkTcSigTyVars )
@@ -56,8 +56,8 @@ import PprType                ( pprConstraint, pprPred )
 import TyCon           ( TyCon, isSynTyCon )
 import Type            ( splitDFunTy, isTyVarTy,
                          splitTyConApp_maybe, splitDictTy,
-                         splitAlgTyConApp_maybe, splitForAllTys,
-                         unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
+                         splitForAllTys,
+                         tyVarsOfTypes, mkClassPred, mkTyVarTy,
                          getClassTys_maybe
                        )
 import Subst           ( mkTopTyVarSubst, substClasses )
@@ -167,11 +167,10 @@ tcInstDecls1 :: PackageInstEnv
             -> TcEnv                   -- Contains IdInfo for dfun ids
             -> (Name -> Maybe Fixity)  -- for deriving Show and Read
             -> Module                  -- Module for deriving
-            -> [TyCon]
             -> [RenamedHsDecl]
             -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
 
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
   = let
        inst_decls = [inst_decl | InstD inst_decl <- decls]     
        tycl_decls = [decl      | TyClD decl <- decls]
@@ -197,6 +196,11 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
                               imported_inst_info
        hst_dfuns        = foldModuleEnv ((++) . md_insts) [] hst
     in
+    traceTc (text "inst env before" <+> pprInstEnv inst_env0)  `thenNF_Tc_`
+    traceTc (vcat [text "imp" <+> ppr imported_dfuns, 
+                  text "hst" <+> ppr hst_dfuns, 
+                  text "local" <+> hsep (map pprInstInfo local_inst_info),
+                  text "gen" <+> hsep (map pprInstInfo generic_inst_info)]) `thenNF_Tc_`
     addInstDFuns inst_env0 imported_dfuns      `thenNF_Tc` \ inst_env1 ->
     addInstDFuns inst_env1 hst_dfuns           `thenNF_Tc` \ inst_env2 ->
     addInstInfos inst_env2 local_inst_info     `thenNF_Tc` \ inst_env3 ->
@@ -208,8 +212,10 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
        -- This stuff computes a context for the derived instance decl, so it
        -- needs to know about all the instances possible; hecne inst_env4
     tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
+    traceTc (vcat [text "deriv" <+> hsep (map pprInstInfo deriv_inst_info)]) `thenNF_Tc_`
     addInstInfos inst_env4 deriv_inst_info             `thenNF_Tc` \ final_inst_env ->
 
+    traceTc (text "inst env after" <+> pprInstEnv final_inst_env)      `thenNF_Tc_`
     returnTc (inst_env1, 
              final_inst_env, 
              generic_inst_info ++ deriv_inst_info ++ local_inst_info,
@@ -221,12 +227,12 @@ addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
 addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
 addInstDFuns dfuns infos
   = getDOptsTc                         `thenTc` \ dflags ->
-    extendInstEnv dflags dfuns infos   `bind`   \ (inst_env', errs) ->
+    let
+       (inst_env', errs) = extendInstEnv dflags dfuns infos
+    in
+    traceTc (text "addInstDFuns" <+> vcat errs)        `thenNF_Tc_`
     addErrsTc errs                     `thenNF_Tc_` 
     returnTc inst_env'
-  where
-    bind x f = f x
-
 \end{code} 
 
 \begin{code}
@@ -369,9 +375,11 @@ getGenericBinds (AndMonoBinds m1 m2)
   = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
 
 getGenericBinds (FunMonoBind id infixop matches loc)
-  = mapAssoc wrap (foldr add emptyAssoc matches)
+  = mapAssoc wrap (foldl add emptyAssoc matches)
+       -- Using foldl not foldr is vital, else
+       -- we reverse the order of the bindings!
   where
-    add match env = case maybeGenericMatch match of
+    add env match = case maybeGenericMatch match of
                      Nothing           -> env
                      Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
 
@@ -578,7 +586,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
         methods_lie = plusLIEs insts_needed_s
     in
 
-       -- Ditto method bindings
+       -- Simplify the constraints from methods
     tcAddErrCtxt methodCtxt (
       tcSimplifyAndCheck
                 (ptext SLIT("instance declaration context"))
@@ -587,11 +595,9 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
                 methods_lie
     )                                           `thenTc` \ (const_lie1, lie_binds1) ->
     
-       -- Now do the simplification again, this time to get the
-       -- bindings; this time we use an enhanced "avails"
-       -- Ignore errors because they come from the *previous* tcSimplify
-    discardErrsTc (
-       tcSimplifyAndCheck
+       -- Figure out bindings for the superclass context
+    tcAddErrCtxt superClassCtxt (
+      tcSimplifyAndCheck
                 (ptext SLIT("instance declaration context"))
                 inst_tyvars_set
                 dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
@@ -613,7 +619,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
                -- emit an error message.  This in turn means that we don't
                -- mention the constructor, which doesn't exist for CCallable, CReturnable
                -- Hardly beautiful, but only three extra lines.
-           HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
+           HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
                  (HsLit (HsString msg))
 
          | otherwise   -- The common case
@@ -723,11 +729,6 @@ scrutiniseInstanceHead clas inst_taus
     maybe_tycon_app      = splitTyConApp_maybe first_inst_tau
     Just (tycon, arg_tys) = maybe_tycon_app
 
-       -- Stuff for an *algebraic* data type
-    alg_tycon_app_maybe           = splitAlgTyConApp_maybe first_inst_tau
-                               -- The "Alg" part looks through synonyms
-    Just (alg_tycon, _, _) = alg_tycon_app_maybe
- 
     ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
     creturnable_type        ty = isFFIResultTy ty
 \end{code}
@@ -791,6 +792,5 @@ nonBoxedPrimCCallErr clas inst_ty
                        ppr inst_ty])
 
 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 \end{code}
-
-