X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=92a39d9e22737f2ddb3e1db3edf70bcd767f5f6a;hb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0;hp=845feccf40ef90d2a92e5507f47096e1fe4933b1;hpb=1c15bee5a8fc004c16693d7d7a2d95b442549b66;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 845fecc..92a39d9 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1240,10 +1240,10 @@ rather than just one level, as we typically do.
 What about types with more than one type parameter?  In general, we only 
 derive Functor for the last position:
 
-  data S a b = S1 [b] | S2 a
+  data S a b = S1 [b] | S2 (a, T a b)
   instance Functor (S a) where
-    fmap f (S1 bs) = S1 (fmap f bs)
-    fmap f (S2 a)  = S2 a
+    fmap f (S1 bs)    = S1 (fmap f bs)
+    fmap f (S2 (p,q)) = S2 (a, fmap f q)
 
 However, we have special cases for
 	 - tuples
@@ -1319,8 +1319,8 @@ functorLikeTraverse :: a                    -- ^ Case: does not contain variable
                     -> a                    -- ^ Case: the variable itself, contravariantly
                     -> (a -> a -> a)        -- ^ Case: function type
                     -> (Boxity -> [a] -> a) -- ^ Case: tuple type
-                    -> (Type -> a -> a)     -- ^ Case: other tycon, variable only in last argument
-                    -> a                    -- ^ Case: other tycon, variable only in last argument
+                    -> (Type -> a -> a)     -- ^ Case: type app, variable only in last argument
+                    -> a                    -- ^ Case: type app, variable other than in last argument
                     -> (TcTyVar -> a -> a)  -- ^ Case: forall type
                     -> TcTyVar              -- ^ Variable to look for
                     -> Type                 -- ^ Type to process
@@ -1334,22 +1334,23 @@ functorLikeTraverse caseTrivial caseVar caseCoVar caseFun caseTuple caseTyApp ca
         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
             where (xr,xc) = go (not co) x
                   (yr,yc) = go co       y
-        go co (AppTy    x y) | xc       = (caseWrongArg,True)
-                             | yc       = (caseTyApp x yr,True)
+        go co (AppTy    x y) | xc = (caseWrongArg,   True)
+                             | yc = (caseTyApp x yr, True)
             where (_, xc) = go co x
                   (yr,yc) = go co y
         go co ty@(TyConApp con args)
-               | isTupleTyCon con       = (caseTuple (tupleTyConBoxity con) xrs,True)
-               | null args              = (caseTrivial,False)
-               | or (init xcs)          = (caseWrongArg,True)
-               | (last xcs)             = (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
+               | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
+               | null args        = (caseTrivial,False)	 -- T
+               | or (init xcs)    = (caseWrongArg,True)	 -- T (..var..)    ty
+               | last xcs         = 			 -- T (..no var..) ty
+	       	      		    (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
             where (xrs,xcs) = unzip (map (go co) args)
         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
             where (xr,xc) = go co x
-        go _  _                         = (caseTrivial,False)
+        go _ _ = (caseTrivial,False)
 
--- return all subtypes of ty that contain var somewhere
--- these are the things that should appear in instance constraints
+-- Return all syntactic subterms of ty that contain var somewhere
+-- These are the things that should appear in instance constraints
 deepSubtypesContaining :: TcTyVar -> TcType -> [TcType]
 deepSubtypesContaining = functorLikeTraverse
       []