testsuite: Add test for #16832 wip/T16832
authorBen Gamari <ben@smart-cactus.org>
Sun, 16 Jun 2019 13:59:17 +0000 (09:59 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sun, 16 Jun 2019 13:59:17 +0000 (09:59 -0400)
testsuite/tests/typecheck/should_compile/T16832.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T16832.script [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

diff --git a/testsuite/tests/typecheck/should_compile/T16832.hs b/testsuite/tests/typecheck/should_compile/T16832.hs
new file mode 100644 (file)
index 0000000..8dcd40f
--- /dev/null
@@ -0,0 +1,40 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module WorkingGenerics where
+import GHC.Generics
+
+-- type family DiffT (p :: * -> *) :: * -> *
+
+data Void  deriving(Generic)
+
+class Diff a  where
+  type family Patch a :: *
+  type Patch a = GPatch (Rep a) a
+
+  diff :: a -> a -> Patch a
+  default diff :: (Generic a, GDiff (Rep a), Patch a ~ (GPatch (Rep a)) a) => a -> a -> Patch a
+  diff a a' = gdiff (from a) (from a')
+
+class GDiff (gen :: * -> *)  where
+  type family GPatch gen :: * -> *
+  gdiff :: gen a -> gen a -> (GPatch gen) a
+
+instance GDiff V1 where
+  type GPatch V1 = V1
+  gdiff v1 _ = undefined
+
+-- meta info, we simply tunnel through
+instance (GDiff f) => GDiff (M1 i t f)  where
+  type GPatch (M1 i t f) =  M1 i t (GPatch f)
+  gdiff (M1 x) (M1 x') = M1 $ gdiff x x'
+
+
+instance Diff Void
+
diff --git a/testsuite/tests/typecheck/should_compile/T16832.script b/testsuite/tests/typecheck/should_compile/T16832.script
new file mode 100644 (file)
index 0000000..8bafa2c
--- /dev/null
@@ -0,0 +1,2 @@
+:load T16832
+
index d0f54c0..8534a2c 100644 (file)
@@ -682,3 +682,4 @@ test('UnliftedNewtypesForall', normal, compile, [''])
 test('UnlifNewUnify', normal, compile, [''])
 test('UnliftedNewtypesLPFamily', normal, compile, [''])
 test('UnliftedNewtypesDifficultUnification', normal, compile, [''])
+test('T16832', normal, ghci_script, [''])