X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=baa751529c6221a8894b1026b3d0da901f6db310;hp=965db1530df58e03610a4c53398d3c80a1eac1c7;hb=46934dd87e13143ec2e97f075309a9e2c0945889;hpb=d95ce839533391e7118257537044f01cbb1d6694

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 965db15..baa7515 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -21,7 +21,7 @@ import FamInst
 import FamInstEnv
 import TcDeriv
 import TcEnv
-import RnEnv	( lookupImportedName )
+import RnEnv	( lookupGlobalOccRn )
 import TcHsType
 import TcUnify
 import TcSimplify
@@ -461,11 +461,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
            ; mapM_ (checkIndexes clas inst_tys) ats
            }
 
-    checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
+    checkIndexes clas inst_tys (hsAT, 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' clas inst_tys hsAT
+                      (tyConTyVars tycon,
+                       snd . fromJust . tyConFamInst_maybe $ tycon)
     checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
@@ -475,8 +475,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         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
+          Just atycon ->
+            case assocTyConArgPoss_maybe atycon of
               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
               Just poss ->
 
@@ -487,6 +487,13 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 -- 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.
+		--
+		-- e.g.    class C a b c where 
+		-- 	     data D b a :: * -> *           -- NB (1) b a, omits c
+		-- 	   instance C [x] Bool Char where 
+		--	     data D Bool [x] v = MkD x [v]  -- NB (2) v
+		--	     	  -- NB (3) the x in 'instance C...' have differnt
+		--		  --        Names to x's in 'data D...'
                 --
                 -- Re (1), `poss' contains a permutation vector to extract the
                 -- class parameters in the right order.
@@ -626,7 +633,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
         ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
 
         ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
-	; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
+        ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 
         ; return (unitBag $ noLoc $
                   AbsBinds inst_tvs' (map instToVar dfun_dicts)
@@ -744,7 +751,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     checkSigTyVars inst_tyvars'
 
     -- Deal with 'SPECIALISE instance' pragmas
-    prags <- tcPrags NonRecursive dfun_id (filter isSpecInstLSig uprags)
+    prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
 
     -- Create the result bindings
     let
@@ -763,7 +770,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
                 --      See Note [Inline dfuns] below
 
         sc_dict_vars  = map instToVar sc_dicts
-        dict_bind     = mkVarBind this_dict_id dict_rhs
+        dict_bind     = L loc (VarBind this_dict_id dict_rhs)
         dict_rhs      = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
  	inst_constr   = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
 				       (dataConWrapId dict_constr)
@@ -774,6 +781,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
                 -- than needing to be repeated here.
 
+
         main_bind = noLoc $ AbsBinds
                             inst_tyvars'
                             dfun_lam_vars
@@ -824,7 +832,7 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
 		-- then clashes with its friends
 	; uniq1 <- newUnique
 	; let local_meth_name = mkInternalName uniq1 sel_occ loc   -- Same OccName
-	      this_dict_bind  = mkVarBind (instToId cloned_this) $ 
+	      this_dict_bind  = L loc $ VarBind (instToId cloned_this) $ 
 				L loc $ wrapId meth_wrapper dfun_id
 	      mb_this_bind | null tyvars = Nothing
 			   | otherwise   = Just (cloned_this, this_dict_bind)
@@ -862,7 +870,7 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
 			{   -- Build the typechecked version directly, 
 			    -- without calling typecheck_method; 
 			    -- see Note [Default methods in instances]
-			  dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
+			  dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
 					-- Might not be imported, but will be an OrigName
 			; dm_id   <- tcLookupId dm_name
 			; return (wrapId dm_wrapper dm_id, emptyBag) } }
@@ -962,7 +970,7 @@ mustBeVarArgErr ty =
 wrongATArgErr :: Type -> Type -> SDoc
 wrongATArgErr ty instTy =
   sep [ ptext (sLit "Type indexes must match class instance head")
-      , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>
-         ppr instTy
+      , ptext (sLit "Found") <+> quotes (ppr ty)
+        <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
       ]
 \end{code}