[commit: ghc] ghc-generics1: change cond_Representable1OK to treat (->) and tuples differently than does cond_FunctorOK (ba692b4)

[José Pedro Magalhães]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-generics1

http://hackage.haskell.org/trac/ghc/changeset/ba692b44a8b64b499ada7145d4843c0cff2073bd

>---------------------------------------------------------------

commit ba692b44a8b64b499ada7145d4843c0cff2073bd
Author: Nicolas Frisby <nicolas.frisby at gmail.com>
Date:   Tue Apr 24 23:14:57 2012 -0500

    change cond_Representable1OK to treat (->) and tuples differently than does cond_FunctorOK
    
    Signed-off-by: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>

>---------------------------------------------------------------

 compiler/typecheck/TcDeriv.lhs       |    3 +--
 compiler/typecheck/TcGenGenerics.lhs |   27 ++++++++++++++++++---------
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index b5fdbc7..06d04f9 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -917,8 +917,7 @@ sideConditions mtheta cls
     	                                   cond_functorOK False)
   | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
                                            checkFlag Opt_DeriveGeneric)
-  | cls_key == gen1ClassKey        = Just (cond_RepresentableOk `andCond`
-                                           cond_Representable1Ok `andCond`
+  | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
                                            checkFlag Opt_DeriveGeneric)
   | otherwise = Nothing
   where
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index fbe6bc0..7389dfa 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -238,15 +238,14 @@ canDoGenerics1 :: TyCon -> Maybe SDoc
 -- Nothing == yes
 -- Just s  == no, because of `s`
 
--- (derived from TcDeriv.cond_functorOK; will be checked only if canDoGenerics
--- passes)
+-- (derived from TcDeriv.cond_functorOK; also checks canDoGenerics)
 
 -- OK for Generic1/Rep1
 -- Currently: (a) at least one argument
 --            (b) don't use argument contravariantly
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) no "stupid context" on data type
-canDoGenerics1 = flip S.evalState [] . canDoGenerics1_w
+canDoGenerics1 t = canDoGenerics t `mplus` S.evalState (canDoGenerics1_w t) []
 
 -- the state is which tycons we have entered; it avoids divergence when we
 -- recur (robust against mutual recursion)
@@ -284,8 +283,18 @@ canDoGenerics1_w rep_tc
     ft_check :: DataCon -> FFoldType (Bool, S.State [Name] (Maybe SDoc))
     ft_check con = FT { ft_triv = bmzero, ft_var = (True, return Nothing)
                       , ft_co_var = (True, return $ Just $ bad con covariant)
-	      	      , ft_fun = bmplus
-                      , ft_tup = \_ -> foldr bmplus bmzero
+                        -- NB foldDataConArgs caters to Functor/Foldable/etc,
+                        -- which treat applications of functions and tuples
+                        -- specially. But we just treat them like normal
+                        -- applications, so we must compensate with extra logic
+                        -- to ensure that the variable only occurs as the last
+                        -- argument.
+	      	      , ft_fun = \x y -> if fst x then (True, return $ Just $ bad con wrong_arg)
+                                         else x `bmplus` y
+                      , ft_tup = \_ xs ->
+                          if not (null xs) && any fst (init xs)
+                          then (True, return $ Just $ bad con wrong_arg)
+                          else foldr bmplus bmzero xs
                       , ft_ty_app = \ty x -> bmplus x $ (,) False $
                           if fst x then representable ty else return Nothing
                       , ft_bad_app = (True, return $ Just $ bad con wrong_arg)
@@ -311,10 +320,10 @@ canDoGenerics1_w rep_tc
               Nothing -> canDoGenerics1_w tc
 
     existential = (ptext . sLit) "must not have existential arguments"
-    covariant   = (ptext . sLit) "must not use the type variable in a function argument"
-    wrong_arg   = (ptext . sLit) "must use the type variable only as the last argument of a data type"
-    bad_app tc  = (ptext . sLit) "must not apply unrepresentable type constructors (such as" <+> ppr (tyConName tc)
-                  <> (ptext . sLit) ") to arguments that involve type parameters"
+    covariant   = (ptext . sLit) "must not use the last type parameter in a function argument"
+    wrong_arg   = (ptext . sLit) "must use the last type parameter only as the last argument of a data type, newtype, or (->)"
+    bad_app tc  = (ptext . sLit) "must not apply type constructors that cannot be represented with `Rep1' (such as `" <> ppr (tyConName tc)
+                  <> (ptext . sLit) "') to arguments that involve the last type parameter"
 
 \end{code}