Improve kind-checking for 'deriving' clauses
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 25 Jun 2015 14:48:37 +0000 (15:48 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 25 Jun 2015 14:49:39 +0000 (15:49 +0100)
The main payload is in 'mk_functor_like_constraints' in
TcDeriv.inferConstraints.

This is moving towards a fix for Trac #10561

compiler/typecheck/TcDeriv.hs
testsuite/tests/deriving/should_compile/T10561.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/T10561.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T
testsuite/tests/deriving/should_fail/T9071.stderr
testsuite/tests/deriving/should_fail/T9071_2.stderr
testsuite/tests/typecheck/should_fail/T9305.stderr

index f99f78b..bbb9dc3 100644 (file)
@@ -1029,7 +1029,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
   | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
   = ASSERT(length rep_tc_tvs > 0)   -- See Note [Getting base classes]
     do { functorClass <- tcLookupClass functorClassName
-       ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
+       ; return (con_arg_constraints (get_gen1_constraints functorClass)) }
 
   | otherwise  -- The others are a bit more complicated
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
@@ -1038,17 +1038,19 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
                  ++ sc_constraints
                  ++ arg_constraints) }
   where
-    arg_constraints = con_arg_constraints cls get_std_constrained_tys
+    arg_constraints = con_arg_constraints get_std_constrained_tys
 
        -- Constraints arising from the arguments of each constructor
-    con_arg_constraints cls' get_constrained_tys
-      = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty])
+    con_arg_constraints :: (CtOrigin -> Type -> [PredOrigin]) -> [PredOrigin]
+    con_arg_constraints get_arg_constraints
+      = [ pred
         | data_con <- tyConDataCons rep_tc
         , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con )
                              zip [1..] $  -- ASSERT is precondition of dataConInstOrigArgTys
                              dataConInstOrigArgTys data_con all_rep_tc_args
         , not (isUnLiftedType arg_ty)
-        , inner_ty <- get_constrained_tys arg_ty ]
+        , let orig = DerivOriginDC data_con arg_n
+        , pred <- get_arg_constraints orig arg_ty ]
 
                 -- No constraints for unlifted types
                 -- See Note [Deriving and unboxed types]
@@ -1059,19 +1061,37 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
                 -- (b) The rep_tc_args will be one short
     is_functor_like =    getUnique cls `elem` functorLikeClassKeys
                       || onlyOneAndTypeConstr inst_tys
-    onlyOneAndTypeConstr [inst_ty] =
-      typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
+    onlyOneAndTypeConstr [inst_ty] = typeKind inst_ty `tcEqKind` a2a_kind
     onlyOneAndTypeConstr _         = False
 
-    get_std_constrained_tys :: Type -> [Type]
-    get_std_constrained_tys ty
-        | is_functor_like = deepSubtypesContaining last_tv ty
-        | otherwise       = [ty]
+    a2a_kind = mkArrowKind liftedTypeKind liftedTypeKind
+
+    get_gen1_constraints functor_cls orig ty
+       = mk_functor_like_constraints orig functor_cls $
+         get_gen1_constrained_tys last_tv ty
+
+    get_std_constrained_tys :: CtOrigin -> Type -> [PredOrigin]
+    get_std_constrained_tys orig ty
+        | is_functor_like = mk_functor_like_constraints orig cls $
+                            deepSubtypesContaining last_tv ty
+        | otherwise       = [mkPredOrigin orig (mkClassPred cls [ty])]
+
+    mk_functor_like_constraints :: CtOrigin -> Class -> [Type] -> [PredOrigin]
+    -- 'cls' is Functor or Traversable etc
+    -- For each type, generate two constraints: (cls ty, kind(ty) ~ (*->*))
+    -- The second constraint checks that the first is well-kinded.
+    -- Lacking that, as Trac #10561 showed, we can just generate an
+    -- ill-kinded instance.
+    mk_functor_like_constraints orig cls tys
+       = [ mkPredOrigin orig pred
+         | ty <- tys
+         , pred <- [ mkClassPred cls [ty]
+                   , mkEqPred (typeKind ty) a2a_kind] ]
 
     rep_tc_tvs = tyConTyVars rep_tc
     last_tv = last rep_tc_tvs
     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
-                      = rep_tc_args ++ [mkTyVarTy last_tv]
+                    = rep_tc_args ++ [mkTyVarTy last_tv]
                     | otherwise       = rep_tc_args
 
         -- Constraints arising from superclasses
diff --git a/testsuite/tests/deriving/should_compile/T10561.hs b/testsuite/tests/deriving/should_compile/T10561.hs
new file mode 100644 (file)
index 0000000..85acc51
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-}
+
+module T10561 where
+
+-- Ultimately this should "Just Work",
+-- but in GHC 7.10 it gave a Lint failure
+-- For now (HEAD, Jun 2015) it gives a kind error message,
+-- which is better than a crash
+
+newtype Compose f g a = Compose (f (g a)) deriving Functor
+
+{-
+instance forall   (f_ant :: k_ans -> *)
+                  (g_anu :: * -> k_ans).
+           (Functor f_ant, Functor g_anu) =>
+             Functor (Compose f_ant g_anu) where
+    fmap f_anv (T10561.Compose a1_anw)
+      = Compose (fmap (fmap f_anv) a1_anw)
+-}
diff --git a/testsuite/tests/deriving/should_compile/T10561.stderr b/testsuite/tests/deriving/should_compile/T10561.stderr
new file mode 100644 (file)
index 0000000..3a158dd
--- /dev/null
@@ -0,0 +1,5 @@
+
+T10561.hs:10:52: error:
+    Couldn't match kind ‘k’ with ‘*’
+      arising from the first field of ‘Compose’ (type ‘f (g a)’)
+    When deriving the instance for (Functor (Compose f g))
index e16d8f5..a01a514 100644 (file)
@@ -53,4 +53,5 @@ test('T9069', normal, compile, [''])
 test('T9359', normal, compile, [''])
 test('T4896', normal, compile, [''])
 test('T7947', extra_clean(['T7947a.o', 'T7947a.hi', 'T7947b.o', 'T7947b.hi']), multimod_compile, ['T7947', '-v0'])
+test('T10561', normal, compile_fail, [''])
 
index 3a09c8e..c2dccbd 100644 (file)
@@ -1,10 +1,7 @@
 [1 of 2] Compiling T9071a           ( T9071a.hs, T9071a.o )
 [2 of 2] Compiling T9071            ( T9071.hs, T9071.o )
 
-T9071.hs:7:37:
-    No instance for (Functor Mu)
+T9071.hs:7:37: error:
+    Couldn't match kind ‘* -> *’ with ‘*’
       arising from the first field of ‘F’ (type ‘Mu (K a)’)
-    Possible fix:
-      use a standalone 'deriving instance' declaration,
-        so you can specify the instance context yourself
     When deriving the instance for (Functor F)
index 65ba471..f618343 100644 (file)
@@ -1,8 +1,5 @@
 
-T9071_2.hs:7:40:
-    No instance for (Functor K1)
+T9071_2.hs:7:40: error:
+    Couldn't match kind ‘* -> *’ with ‘*’
       arising from the first field of ‘F1’ (type ‘Mu (K1 a)’)
-    Possible fix:
-      use a standalone 'deriving instance' declaration,
-        so you can specify the instance context yourself
     When deriving the instance for (Functor F1)
index c908a56..e7c761e 100644 (file)
@@ -1,8 +1,5 @@
 
-T9305.hs:8:48:
-    No instance for (Functor F)
+T9305.hs:8:48: error:
+    Couldn't match kind ‘* -> *’ with ‘*’
       arising from the first field of ‘EventF’ (type ‘F (Event a)’)
-    Possible fix:
-      use a standalone 'deriving instance' declaration,
-        so you can specify the instance context yourself
     When deriving the instance for (Functor EventF)