Allow left ∨ (+++) as minimal definition of ArrowChoice instance

See #10911.

Reviewers: ekmett

Signed-off-by: Austin Seipp <austin@well-typed.com>

1 files changed, 7 insertions, 6 deletions

diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs
index 1cc6062516..2e2c4700a4 100644
--- a/libraries/base/Control/Arrow.hs
+++ b/libraries/base/Control/Arrow.hs
@@ -219,17 +219,14 @@ class Arrow a => ArrowChoice a where
     -- | Feed marked inputs through the argument arrow, passing the
     --   rest through unchanged to the output.
     left :: a b c -> a (Either b d) (Either c d)
+    left = (+++ id)
 
     -- | A mirror image of 'left'.
     --
     --   The default definition may be overridden with a more efficient
     --   version if desired.
     right :: a b c -> a (Either d b) (Either d c)
-    right f = arr mirror >>> left f >>> arr mirror
-      where
-        mirror :: Either x y -> Either y x
-        mirror (Left x) = Right x
-        mirror (Right y) = Left y
+    right = (id +++)
 
     -- | Split the input between the two argument arrows, retagging
     --   and merging their outputs.
@@ -238,7 +235,11 @@ class Arrow a => ArrowChoice a where
     --   The default definition may be overridden with a more efficient
     --   version if desired.
     (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
-    f +++ g = left f >>> right g
+    f +++ g = left f >>> arr mirror >>> left g >>> arr mirror
+      where
+        mirror :: Either x y -> Either y x
+        mirror (Left x) = Right x
+        mirror (Right y) = Left y
 
     -- | Fanin: Split the input between the two argument arrows and
     --   merge their outputs.