Big tidy-up of deriving code

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

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index ac5c896..fe7b1d8 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -221,7 +221,7 @@ addFamInsts tycons thing_inside
     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
     mkLocalFamInstTyThing tything       = pprPanic "TcInstDcls.addFamInsts"
                                                    (ppr tything)
-\end{code} 
+\end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name 
@@ -240,11 +240,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
        ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
                  badBootDeclErr
 
-       -- Typecheck the instance type itself.  We can't use 
-       -- tcHsSigType, because it's not a valid user type.
-       ; kinded_ty <- kcHsSigType poly_ty
-       ; poly_ty'  <- tcHsKindedType kinded_ty
-       ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+       ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
        
        -- Next, process any associated types.
        ; idx_tycons <- mappM tcIdxTyInstDecl ats
@@ -483,7 +479,7 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 
 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
   = do { let dfun_id      = instanceDFunId ispec 
-             rigid_info   = InstSkol dfun_id
+             rigid_info   = InstSkol
              origin       = SigOrigin rigid_info
              inst_ty      = idType dfun_id
        ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
@@ -518,7 +514,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
     make_wrapper inst_loc tvs theta (Just preds)       -- Case (a)
       = ASSERT( null tvs && null theta )
        do { dicts <- newDictBndrs inst_loc preds
-          ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts)
+          ; sc_binds <- addErrCtxt superClassCtxt $
+                        tcSimplifySuperClasses inst_loc [] dicts
                -- Use tcSimplifySuperClasses to avoid creating loops, for the
                -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
           ; return (map instToId dicts, idHsWrapper, sc_binds) }
@@ -584,7 +581,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
   = let 
        dfun_id    = instanceDFunId ispec
-       rigid_info = InstSkol dfun_id
+       rigid_info = InstSkol
        inst_ty    = idType dfun_id
     in
         -- Prime error recovery
@@ -610,7 +607,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     newDictBndrs sc_loc sc_theta'                      `thenM` \ sc_dicts ->
     getInstLoc origin                                  `thenM` \ inst_loc -> 
     newDictBndrs inst_loc dfun_theta'                  `thenM` \ dfun_arg_dicts ->
-    newDictBndr inst_loc (mkClassPred clas inst_tys')  `thenM` \ this_dict ->
+    newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
                -- Default-method Ids may be mentioned in synthesised RHSs,
                -- but they'll already be in the environment.
 
@@ -626,9 +623,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
        -- Don't include this_dict in the 'givens', else
        -- sc_dicts get bound by just selecting  from this_dict!!
     addErrCtxt superClassCtxt
-       (tcSimplifySuperClasses inst_tyvars'
-                        dfun_arg_dicts
-                        sc_dicts)      `thenM` \ sc_binds ->
+       (tcSimplifySuperClasses inst_loc
+                        dfun_arg_dicts sc_dicts)       `thenM` \ sc_binds ->
 
        -- It's possible that the superclass stuff might unified one
        -- of the inst_tyavars' with something in the envt