Support unions of more than 2 elements correctly (#308)

Author: serras

adapter/protobuf/mu-protobuf.cabal

@@ -63,4 +63,4 @@ executable test-protobuf
 
   hs-source-dirs:   test
   default-language: Haskell2010
-  ghc-options:      -Wall -fprint-explicit-foralls
+  ghc-options:      -Wall -fprint-explicit-foralls -fprint-potential-instances

adapter/protobuf/test/ProtoBuf.hs

@@ -55,11 +55,18 @@ data MPerson
   deriving (FromSchema ExampleSchema "person")
 
 newtype MFoo
-  = MFoo { fooChoice :: Either Int32 T.Text }
+  = MFoo { fooChoice :: MFooChoice }
   deriving (Eq, Show, Generic)
   deriving (ToSchema ExampleSchema "Foo")
   deriving (FromSchema ExampleSchema "Foo")
 
+data MFooChoice
+  = FooInt Int32
+  | FooString T.Text
+  | FooOtherInt Int32
+  | FooYetAnotherInt Int32
+  deriving (Eq, Show, Generic)
+
 data MAddress
   = MAddress { postcode :: T.Text
              , country  :: T.Text }
@@ -75,11 +82,11 @@ examplePerson1 = MPerson "Pythonio" "van Gogh"
                          30 Male
                          exampleAddress [1,2,3]
                          (M.fromList [("hola", 1), ("hello", 2), ("hallo", 3)])
-                         (Just $ MFoo $ Right "blah")
+                         (Just $ MFoo $ FooString "blah")
 examplePerson2 = MPerson "Cuarenta" "Siete"
                          0 NB
                          exampleAddress [] M.empty
-                         (Just $ MFoo $ Left 3)
+                         (Just $ MFoo $ FooInt 3)
 
 main :: IO ()
 main = do -- Obtain the filenames

adapter/protobuf/test/protobuf/example.proto

@@ -26,5 +26,7 @@ message Foo {
   oneof fooChoice {
     int32 foo_int = 1;
     string foo_string = 2;
+    int32 foo_other_int = 3;
+    int32 foo_yet_another_int = 4;
   }
 }

core/schema/src/Mu/Schema/Class.hs

@@ -394,30 +394,30 @@ instance {-# OVERLAPS #-} (GFromSchemaFieldTypeUnion sch (a ': b ': rest) v)
          => GFromSchemaFieldTypeUnion sch (a ': b ': rest) (M1 i t v) where
   fromSchemaFieldTypeUnion x = M1 (fromSchemaFieldTypeUnion x)
 
-instance (GToSchemaFieldTypeWrap sch t v, GToSchemaFieldTypeUnion sch ts vs)
+instance {-# OVERLAPPABLE #-} (GToSchemaFieldTypeWrap sch t v, GToSchemaFieldTypeUnion sch ts vs)
          => GToSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where
   toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x)
   toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r)
-instance (GFromSchemaFieldTypeWrap sch t v, GFromSchemaFieldTypeUnion sch ts vs)
+instance {-# OVERLAPPABLE #-} (GFromSchemaFieldTypeWrap sch t v, GFromSchemaFieldTypeUnion sch ts vs)
          => GFromSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where
   fromSchemaFieldTypeUnion (Z x) = L1 (fromSchemaFieldTypeW x)
   fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r)
 -- Weird nested instance produced by GHC
-instance ( GToSchemaFieldTypeWrap sch t1 v1
-         , GToSchemaFieldTypeWrap sch t2 v2
-         , GToSchemaFieldTypeUnion sch ts vs )
-         => GToSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
-  toSchemaFieldTypeUnion (L1 (L1 x)) = Z (toSchemaFieldTypeW x)
-  toSchemaFieldTypeUnion (L1 (R1 x)) = S (Z (toSchemaFieldTypeW x))
-  toSchemaFieldTypeUnion (R1 r)      = S (S (toSchemaFieldTypeUnion r))
-instance ( GFromSchemaFieldTypeWrap sch t1 v1
-         , GFromSchemaFieldTypeWrap sch t2 v2
-         , GFromSchemaFieldTypeUnion sch ts vs )
-         => GFromSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where
-  fromSchemaFieldTypeUnion (Z x)     = L1 (L1 (fromSchemaFieldTypeW x))
-  fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x))
-  fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r)
-
+instance {-# OVERLAPS #-} ( GToSchemaFieldTypeUnion sch (t ': ts) (v1 :+: (v2 :+: vs)) )
+         => GToSchemaFieldTypeUnion sch (t ': ts) ((v1 :+: v2) :+: vs) where
+  toSchemaFieldTypeUnion (L1 (L1 x))
+    = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (L1 x)
+  toSchemaFieldTypeUnion (L1 (R1 x))
+    = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (R1 (L1 x))
+  toSchemaFieldTypeUnion (R1 r)
+    = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (R1 (R1 r))
+instance {-# OVERLAPS #-} ( GFromSchemaFieldTypeUnion sch (t ': ts) (v1 :+: (v2 :+: vs)) )
+         => GFromSchemaFieldTypeUnion sch (t ': ts) ((v1 :+: v2) :+: vs) where
+  fromSchemaFieldTypeUnion t
+    = case fromSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) t of
+        L1 x      -> L1 (L1 x)
+        R1 (L1 x) -> L1 (R1 x)
+        R1 (R1 x) -> R1 x
 
 -- ---------------
 -- ENUMERATIONS --