Basic set up for global family instance environment
[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs
index 45338d0..6135ca2 100644 (file)
@@ -10,34 +10,55 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 
 import HsSyn
 import TcBinds         ( mkPragFun, tcPrags, badBootDeclErr )
-import TcClassDcl      ( tcMethodBind, mkMethodBind, badMethodErr, 
-                         tcClassDecl2, getGenericInstances )
+import TcTyClsDecls     ( tcIdxTyInstDecl )
+import TcClassDcl      ( tcMethodBind, mkMethodBind, badMethodErr, badATErr,
+                         omittedATWarn, tcClassDecl2, getGenericInstances )
 import TcRnMonad       
-import TcMType         ( tcSkolSigType, checkValidInstance, checkValidInstHead )
-import TcType          ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
-                         SkolemInfo(InstSkol), tcSplitDFunTy )
-import Inst            ( tcInstClassOp, newDicts, instToId, showLIE, 
+import TcMType         ( tcSkolSigType, checkValidInstance,
+                         checkValidInstHead )
+import TcType          ( TcType, mkClassPred, tcSplitSigmaTy,
+                         tcSplitDFunHead,  SkolemInfo(InstSkol),
+                         tcSplitDFunTy, mkFunTy ) 
+import Inst            ( newDictBndr, newDictBndrs, instToId, showLIE, 
                          getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv         ( mkLocalInstance, instanceDFunId )
+import FamInst         ( tcExtendLocalFamInstEnv )
+import FamInstEnv      ( extractFamInsts )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( InstInfo(..), InstBindings(..), 
-                         newDFunName, tcExtendIdEnv
+                         newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
                        )
 import TcHsType                ( kcHsSigType, tcHsKindedType )
 import TcUnify         ( checkSigTyVars )
-import TcSimplify      ( tcSimplifyCheck, tcSimplifySuperClasses )
-import Type            ( zipOpenTvSubst, substTheta, substTys )
-import DataCon         ( classDataCon )
-import Class           ( classBigSig )
-import Var             ( Id, idName, idType )
+import TcSimplify      ( tcSimplifySuperClasses )
+import Type            ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
+                          splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType,
+                          substTys, emptyTvSubst, extendTvSubst )
+import Coercion         ( mkSymCoercion )
+import TyCon            ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars,
+                         isTyConAssoc, tyConFamInst_maybe,
+                         assocTyConArgPoss_maybe )
+import DataCon         ( classDataCon, dataConTyCon, dataConInstArgTys )
+import Class           ( Class, classBigSig, classATs )
+import Var             ( TyVar, Id, idName, idType, tyVarKind, tyVarName )
+import VarEnv           ( rnBndrs2, mkRnEnv2, emptyInScopeSet )
+import Id               ( mkSysLocal )
+import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
 import MkId            ( mkDictFunId )
-import Name            ( Name, getSrcLoc )
-import Maybe           ( catMaybes )
-import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
+import Name            ( Name, getSrcLoc, nameOccName )
+import NameSet         ( addListToNameSet, emptyNameSet, minusNameSet,
+                         nameSetToList ) 
+import Maybe           ( isNothing, fromJust, catMaybes )
+import Monad           ( when )
+import List            ( find )
+import DynFlags                ( DynFlag(Opt_WarnMissingMethods) )
+import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart,
+                         getLoc)
 import ListSetOps      ( minusList )
 import Outputable
 import Bag
 import BasicTypes      ( Activation( AlwaysActive ), InlineSpec(..) )
+import HscTypes                ( implicitTyThings )
 import FastString
 \end{code}
 
@@ -51,7 +72,6 @@ pass, when the class-instance envs and GVE contain all the info from
 all the instance and value decls.  Indeed that's the reason we need
 two passes over the instance decls.
 
-
 Here is the overall algorithm.
 Assume that we have an instance declaration
 
@@ -134,51 +154,92 @@ tcInstDecls1      -- Deal with both source-code and imported instance decls
 
 tcInstDecls1 tycl_decls inst_decls
   = checkNoErrs $
-       -- Stop if addInstInfos etc discovers any errors
-       -- (they recover, so that we get more than one error each round)
-
-       -- (1) Do the ordinary instance declarations
-    mappM tcLocalInstDecl1 inst_decls    `thenM` \ local_inst_infos ->
-
-    let
-       local_inst_info = catMaybes local_inst_infos
-       clas_decls      = filter (isClassDecl.unLoc) tycl_decls
-    in
-       -- (2) Instances from generic class declarations
-    getGenericInstances clas_decls     `thenM` \ generic_inst_info -> 
-
-       -- Next, construct the instance environment so far, consisting of
-       --      a) local instance decls
-       --      b) generic instances
-    addInsts local_inst_info   $
-    addInsts generic_inst_info $
-
-       -- (3) Compute instances from "deriving" clauses; 
-       -- This stuff computes a context for the derived instance decl, so it
-       -- needs to know about all the instances possible; hence inst_env4
-    tcDeriving tycl_decls      `thenM` \ (deriv_inst_info, deriv_binds) ->
-    addInsts deriv_inst_info   $
-
-    getGblEnv                  `thenM` \ gbl_env ->
-    returnM (gbl_env, 
-            generic_inst_info ++ deriv_inst_info ++ local_inst_info,
-            deriv_binds)
+    do {        -- Stop if addInstInfos etc discovers any errors
+               -- (they recover, so that we get more than one error each
+               -- round) 
+
+               -- (1) Do class instance declarations and instances of indexed
+               --     types 
+       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
+       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
+       ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
+
+       ; let { (local_infos,
+               at_tycons)     = unzip local_info_tycons
+            ; local_info      = concat local_infos
+            ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
+            ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls 
+            ; implicit_things = concatMap implicitTyThings at_idx_tycon
+            }
+
+               -- (2) Add the tycons of indexed types and their implicit
+               --     tythings to the global environment
+       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
+
+               -- (3) Instances from generic class declarations
+       ; generic_inst_info <- getGenericInstances clas_decls
+
+               -- Next, construct the instance environment so far, consisting
+               -- of 
+               --   a) local instance decls
+               --   b) generic instances
+               --   c) local family instance decls
+       ; addInsts local_info         $ do {
+       ; addInsts generic_inst_info  $ do {
+       ; addFamInsts at_idx_tycon    $ do {
+
+               -- (4) Compute instances from "deriving" clauses; 
+               -- This stuff computes a context for the derived instance
+               -- decl, so it needs to know about all the instances possible
+       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
+       ; addInsts deriv_inst_info   $ do {
+
+       ; gbl_env <- getGblEnv
+       ; returnM (gbl_env, 
+                 generic_inst_info ++ deriv_inst_info ++ local_info,
+                 deriv_binds) 
+    }}}}}}
+  where
+    -- Make sure that toplevel type instance are not for associated types.
+    -- !!!TODO: Need to perform this check for the TyThing of type functions,
+    --         too.
+    tcIdxTyInstDeclTL ldecl@(L loc decl) =
+      do { tything <- tcIdxTyInstDecl ldecl
+        ; setSrcSpan loc $
+            when (isAssocFamily tything) $
+              addErr $ assocInClassErr (tcdName decl)
+        ; return tything
+        }
+    isAssocFamily (Just (ATyCon tycon)) =
+      case tyConFamInst_maybe tycon of
+        Nothing       -> panic "isAssocFamily: no family?!?"
+       Just (fam, _) -> isTyConAssoc fam
+    isAssocFamily (Just _            ) = panic "isAssocFamily: no tycon?!?"
+    isAssocFamily Nothing               = False
+
+assocInClassErr name = 
+  ptext SLIT("Associated type") <+> quotes (ppr name) <+> 
+  ptext SLIT("must be inside a class instance")
 
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
+addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts tycons thing_inside
+  = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside
 \end{code} 
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name 
-                -> TcM (Maybe InstInfo)        -- Nothing if there was an error
+                -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
        -- A source-file instance declaration
        -- Type-check all the stuff before the "where"
        --
        -- We check for respectable instance type, and context
-tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
+tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
   =    -- Prime error recovery, set source location
-    recoverM (returnM Nothing)         $
+    recoverM (returnM ([], []))                $
     setSrcSpan loc                     $
     addErrCtxt (instDeclCtxt1 poly_ty) $
 
@@ -192,15 +253,118 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
        ; poly_ty'  <- tcHsKindedType kinded_ty
        ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
        
+       -- Next, process any associated types.
+       ; idx_tycons <- mappM tcIdxTyInstDecl ats
+
+       -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
        ; checkValidInstance tyvars theta clas inst_tys
+       ; checkValidAndMissingATs clas (tyvars, inst_tys) 
+                                 (zip ats idx_tycons)
 
+       -- Finally, construct the Core representation of the instance.
+       -- (This no longer includes the associated types.)
        ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
        ; overlap_flag <- getOverlapFlag
-       ; let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
-             ispec = mkLocalInstance dfun overlap_flag
+       ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
+             ispec          = mkLocalInstance dfun overlap_flag
 
-       ; return (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) }
+       ; return ([InstInfo { iSpec  = ispec, 
+                             iBinds = VanillaInst binds uprags }],
+                 catMaybes idx_tycons)
+        }
+  where
+    -- We pass in the source form and the type checked form of the ATs.  We
+    -- really need the source form only to be able to produce more informative
+    -- error messages.
+    checkValidAndMissingATs :: Class
+                           -> ([TyVar], [TcType])     -- instance types
+                           -> [(LTyClDecl Name,       -- source form of AT
+                                Maybe TyThing)]       -- Core form of AT
+                           -> TcM ()
+    checkValidAndMissingATs clas inst_tys ats
+      = do { -- Issue a warning for each class AT that is not defined in this
+            -- instance.
+          ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
+                 definedATs  = listToNameSet . map (tcdName.unLoc.fst)  $ ats
+                omitted     = classDefATs `minusNameSet` definedATs
+          ; warn <- doptM Opt_WarnMissingMethods
+          ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
+          
+            -- Ensure that all AT indexes that correspond to class parameters
+            -- coincide with the types in the instance head.  All remaining
+            -- AT arguments must be variables.  Also raise an error for any
+            -- type instances that are not associated with this class.
+          ; mapM_ (checkIndexes clas inst_tys) ats
+          }
+
+    checkIndexes _    _        (hsAT, Nothing)             = 
+      return ()           -- skip, we already had an error here
+    checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = 
+-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
+      checkIndexes' clas inst_tys hsAT 
+                   (tyConTyVars tycon, 
+                    snd . fromJust . tyConFamInst_maybe $ tycon)
+    checkIndexes _ _ _ = panic "checkIndexes"
+
+    checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
+      = let atName = tcdName . unLoc $ hsAT
+       in
+       setSrcSpan (getLoc hsAT)       $
+       addErrCtxt (atInstCtxt atName) $
+       case find ((atName ==) . tyConName) (classATs clas) of
+         Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
+         Just atDecl -> 
+           case assocTyConArgPoss_maybe atDecl of
+             Nothing   -> panic "checkIndexes': AT has no args poss?!?"
+             Just poss -> 
+
+               -- The following is tricky!  We need to deal with three
+               -- complications: (1) The AT possibly only uses a subset of
+               -- the class parameters as indexes and those it uses may be in
+               -- a different order; (2) the AT may have extra arguments,
+               -- which must be type variables; and (3) variables in AT and
+               -- instance head will be different `Name's even if their
+               -- source lexemes are identical.
+               --
+               -- Re (1), `poss' contains a permutation vector to extract the
+               -- class parameters in the right order.
+               --
+               -- Re (2), we wrap the (permuted) class parameters in a Maybe
+               -- type and use Nothing for any extra AT arguments.  (First
+               -- equation of `checkIndex' below.)
+               --
+               -- Re (3), we replace any type variable in the AT parameters
+               -- that has the same source lexeme as some variable in the
+               -- instance types with the instance type variable sharing its
+               -- source lexeme.
+               --
+               let relevantInstTys = map (instTys !!) poss
+                   instArgs        = map Just relevantInstTys ++ 
+                                     repeat Nothing  -- extra arguments
+                   renaming        = substSameTyVar atTvs instTvs
+               in
+               zipWithM_ checkIndex (substTys renaming atTys) instArgs
+
+    checkIndex ty Nothing 
+      | isTyVarTy ty         = return ()
+      | otherwise            = addErrTc $ mustBeVarArgErr ty
+    checkIndex ty (Just instTy) 
+      | ty `tcEqType` instTy = return ()
+      | otherwise            = addErrTc $ wrongATArgErr ty instTy
+
+    listToNameSet = addListToNameSet emptyNameSet 
+
+    substSameTyVar []       _            = emptyTvSubst
+    substSameTyVar (tv:tvs) replacingTvs = 
+      let replacement = case find (tv `sameLexeme`) replacingTvs of
+                         Nothing  -> mkTyVarTy tv
+                         Just rtv -> mkTyVarTy rtv
+          --
+          tv1 `sameLexeme` tv2 = 
+           nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
+      in
+      extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
 \end{code}
 
 
@@ -303,8 +467,100 @@ First comes the easy case of a non-local instance decl.
 
 \begin{code}
 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
+-- Returns a binding for the dfun
 
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
+------------------------
+-- Derived newtype instances
+--
+-- We need to make a copy of the dictionary we are deriving from
+-- because we may need to change some of the superclass dictionaries
+-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
+--
+-- In the case of a newtype, things are rather easy
+--     class Show a => Foo a b where ...
+--     newtype T a = MkT (Tree [a]) deriving( Foo Int )
+-- The newtype gives an FC axiom looking like
+--     axiom CoT a ::  T a :=: Tree [a]
+--
+-- So all need is to generate a binding looking like
+--     dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
+--     dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
+--               case df `cast` (Foo Int (sym (CoT a))) of
+--                  Foo _ op1 .. opn -> Foo ds op1 .. opn
+
+tcInstDecl2 (InstInfo { iSpec = ispec, 
+                       iBinds = NewTypeDerived tycon rep_tys })
+  = do { let dfun_id      = instanceDFunId ispec 
+             rigid_info   = InstSkol dfun_id
+             origin       = SigOrigin rigid_info
+             inst_ty      = idType dfun_id
+       ; inst_loc <- getInstLoc origin
+       ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
+       ; dicts <- newDictBndrs inst_loc theta
+        ; uniqs <- newUniqueSupply
+        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
+        ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
+        ; let (rep_dict_id:sc_dict_ids)
+                 | null dicts = [instToId this_dict]
+                | otherwise  = map instToId dicts
+
+               -- (Here, we are relying on the order of dictionary 
+               -- arguments built by NewTypeDerived in TcDeriv.)
+
+              wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
+          
+                -- we need to find the kind that this class applies to
+                -- and drop trailing tvs appropriately
+              cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon)))
+              the_tvs  = drop_tail (length (fst (splitFunTys cls_kind))) tvs
+
+              coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id)
+
+             body | null sc_dict_ids = coerced_rep_dict
+                  | otherwise = HsCase (noLoc coerced_rep_dict) $
+                                MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
+             in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+
+              the_match = mkSimpleMatch [noLoc the_pat] the_rhs
+             the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
+
+             (uniqs1, uniqs2) = splitUniqSupply uniqs
+
+             op_ids = zipWith (mkSysLocal FSLIT("op"))
+                                     (uniqsFromSupply uniqs1) op_tys
+
+              dict_ids = zipWith (mkSysLocal FSLIT("dict"))
+                          (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
+
+             the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+                                   pat_dicts = dict_ids,
+                                   pat_binds = emptyLHsBinds,
+                                   pat_args = PrefixCon (map nlVarPat op_ids),
+                                   pat_ty = in_dict_ty} 
+
+              cls_data_con = classDataCon cls
+              cls_tycon    = dataConTyCon cls_data_con
+              cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys 
+              
+              n_dict_args = if length dicts == 0 then 0 else length dicts - 1
+              op_tys = drop n_dict_args cls_arg_tys
+              
+              dict    = mkHsCoerce wrap_fn body
+        ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }
+  where
+       -- For newtype T a = MkT <ty>
+       -- The returned coercion has kind :: C (T a):=:C <ty>
+    co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo_maybe tycon
+          = ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
+                      [mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
+          | otherwise
+          = idCoercion
+    drop_tail n l = take (length l - n) l
+
+------------------------
+-- Ordinary instances
+
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
   = let 
        dfun_id    = instanceDFunId ispec
        rigid_info = InstSkol dfun_id
@@ -329,9 +585,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
        origin    = SigOrigin rigid_info
     in
         -- Create dictionary Ids from the specified instance contexts.
-    newDicts InstScOrigin sc_theta'                    `thenM` \ sc_dicts ->
-    newDicts origin dfun_theta'                                `thenM` \ dfun_arg_dicts ->
-    newDicts origin [mkClassPred clas inst_tys']       `thenM` \ [this_dict] ->
+    getInstLoc InstScOrigin                            `thenM` \ sc_loc -> 
+    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 ->
                -- Default-method Ids may be mentioned in synthesised RHSs,
                -- but they'll already be in the environment.
 
@@ -341,7 +599,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
     in
     tcMethods origin clas inst_tyvars' 
              dfun_theta' inst_tys' avail_insts 
-             op_items binds            `thenM` \ (meth_ids, meth_binds) ->
+             op_items monobinds uprags         `thenM` \ (meth_ids, meth_binds) ->
 
        -- Figure out bindings for the superclass context
        -- Don't include this_dict in the 'givens', else
@@ -356,12 +614,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
     checkSigTyVars inst_tyvars'        `thenM_`
 
        -- Deal with 'SPECIALISE instance' pragmas 
-    let
-       specs = case binds of
-                 VanillaInst _ prags -> filter isSpecInstLSig prags
-                 other               -> []
-    in
-    tcPrags dfun_id specs                      `thenM` \ prags -> 
+    tcPrags dfun_id (filter isSpecInstLSig uprags)     `thenM` \ prags -> 
     
        -- Create the result bindings
     let
@@ -405,7 +658,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 
 
 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
-         avail_insts op_items (VanillaInst monobinds uprags)
+         avail_insts op_items monobinds uprags
   =    -- Check that all the method bindings come from this class
     let
        sel_names = [idName sel_id | (sel_id, _) <- op_items]
@@ -451,48 +704,16 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
     let
        prag_fn        = mkPragFun uprags
        all_insts      = avail_insts ++ catMaybes meth_insts
-       tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
+       sig_fn n       = Just []        -- No scoped type variables, but every method has
+                                       -- a type signature, in effect, so that we check
+                                       -- the method has the right type
+       tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
        meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
     in
 
     mapM tc_method_bind meth_infos             `thenM` \ meth_binds_s ->
    
     returnM (meth_ids, unionManyBags meth_binds_s)
-
-
--- Derived newtype instances
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
-         avail_insts op_items (NewTypeDerived rep_tys)
-  = getInstLoc origin                          `thenM` \ inst_loc ->
-    mapAndUnzip3M (do_one inst_loc) op_items   `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
-    
-    tcSimplifyCheck
-        (ptext SLIT("newtype derived instance"))
-        inst_tyvars' avail_insts rhs_insts     `thenM` \ lie_binds ->
-
-       -- I don't think we have to do the checkSigTyVars thing
-
-    returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
-
-  where
-    do_one inst_loc (sel_id, _)
-       = -- The binding is like "op @ NewTy = op @ RepTy"
-               -- Make the *binder*, like in mkMethodBind
-         tcInstClassOp inst_loc sel_id inst_tys'       `thenM` \ meth_inst ->
-
-               -- Make the *occurrence on the rhs*
-         tcInstClassOp inst_loc sel_id rep_tys'        `thenM` \ rhs_inst ->
-         let
-            meth_id = instToId meth_inst
-         in
-         return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-
-       -- Instantiate rep_tys with the relevant type variables
-       -- This looks a bit odd, because inst_tyvars' are the skolemised version
-       -- of the type variables in the instance declaration; but rep_tys doesn't
-       -- have the skolemised version, so we substitute them in here
-    rep_tys' = substTys subst rep_tys
-    subst    = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
 \end{code}
 
 
@@ -607,4 +828,19 @@ instDeclCtxt2 dfun_ty
 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
 
 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
+
+atInstCtxt name = ptext SLIT("In the associated type instance for") <+> 
+                 quotes (ppr name)
+
+mustBeVarArgErr ty = 
+  sep [ ptext SLIT("Arguments that do not correspond to a class parameter") <+>
+        ptext SLIT("must be variables")
+      , ptext SLIT("Instead of a variable, found") <+> ppr ty
+      ]
+
+wrongATArgErr ty instTy =
+  sep [ ptext SLIT("Type indexes must match class instance head")
+      , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>
+         ppr instTy
+      ]
 \end{code}