[project @ 2000-11-08 14:52:06 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 0280341..8b145d5 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, classDataCon, extendInstEnv )
+import InstEnv         ( InstEnv, extendInstEnv )
 import TcMonoType      ( tcTyVars, tcHsSigType, kcHsSigType )
 import TcSimplify      ( tcSimplifyAndCheck )
 import TcType          ( zonkTcSigTyVars )
@@ -42,6 +42,7 @@ import HscTypes               ( HomeSymbolTable, DFunId,
                        )
 
 import Bag             ( unionManyBags )
+import DataCon         ( classDataCon )
 import Class           ( Class, DefMeth(..), classBigSig )
 import Var             ( idName, idType )
 import Maybes          ( maybeToBool )
@@ -52,11 +53,11 @@ import Name         ( getSrcLoc )
 import NameSet         ( emptyNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprConstraint, pprPred )
-import TyCon           ( TyCon, isSynTyCon, tyConDerivings )
+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 )
@@ -172,8 +173,9 @@ tcInstDecls1 :: PackageInstEnv
 
 tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
   = let
-       inst_decls = [inst_decl | InstD inst_decl <- decls]
-       clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
+       inst_decls = [inst_decl | InstD inst_decl <- decls]     
+       tycl_decls = [decl      | TyClD decl <- decls]
+       clas_decls = filter isClassDecl tycl_decls
     in
        -- (1) Do the ordinary instance declarations
     mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls      `thenNF_Tc` \ inst_infos ->
@@ -205,7 +207,7 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
        --     we ignore deriving decls from interfaces!
        -- 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 tycons     `thenTc` \ (deriv_inst_info, deriv_binds) ->
+    tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
     addInstInfos inst_env4 deriv_inst_info             `thenNF_Tc` \ final_inst_env ->
 
     returnTc (inst_env1, 
@@ -367,9 +369,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'])
 
@@ -611,7 +615,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
@@ -687,13 +691,6 @@ scrutiniseInstanceHead clas inst_taus
             && not (creturnable_type first_inst_tau))
      -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 
-       -- DERIVING CHECK
-       -- It is obviously illegal to have an explicit instance
-       -- for something that we are also planning to `derive'
-     |  maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
-     -> addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-          -- Kind check will have ensured inst_taus is of length 1
-
        -- Allow anything for AllowUndecidableInstances
      |  dopt Opt_AllowUndecidableInstances dflags
      -> returnNF_Tc ()
@@ -728,11 +725,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}
@@ -790,12 +782,6 @@ instTypeErr clas tys msg
         nest 4 (parens msg)
     ]
 
-derivingWhenInstanceExistsErr clas tycon
-  = hang (hsep [ptext SLIT("Deriving class"), 
-                      quotes (ppr clas), 
-                      ptext SLIT("type"), quotes (ppr tycon)])
-         4 (ptext SLIT("when an explicit instance exists"))
-
 nonBoxedPrimCCallErr clas inst_ty
   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
         4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),