From 688219e380fb5c9181f65d7bea01efed2b9c5032 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Mon, 5 Nov 2018 11:06:59 -0500
Subject: [PATCH] Arrow instance, why not

---
 src/Control/Matching.hs  | 9 ++++++++-
 src/Control/Rewriting.hs | 3 ---
 src/Prologue.hs          | 5 +++++
 3 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/Control/Matching.hs b/src/Control/Matching.hs
index da77bf684..35c71ef1c 100644
--- a/src/Control/Matching.hs
+++ b/src/Control/Matching.hs
@@ -30,9 +30,10 @@ module Control.Matching
   ) where
 
 import Prelude hiding (id, (.))
-import Prologue hiding (project)
+import Prologue hiding (First, project)
 
 import Control.Category
+import Control.Arrow
 
 import Data.Sum
 import Data.Term
@@ -54,6 +55,7 @@ data Matcher t a where
   Target :: Matcher t t
   Empty  :: Matcher t a
   Comp   :: Matcher b c -> Matcher a b -> Matcher a c
+  Split  :: Matcher b c -> Matcher b' c' -> Matcher (b, b') (c, c')
   -- We could have implemented this by changing the semantics of how Then is interpreted, but that would make Then and Sequence inconsistent.
   Match  :: (t -> Maybe u) -> Matcher u a -> Matcher t a
   Pure   :: a -> Matcher t a
@@ -82,6 +84,10 @@ instance Category Matcher where
   id  = Target
   (.) = Comp
 
+instance Arrow Matcher where
+  (***) = Split
+  arr = purely
+
 -- | This matcher always succeeds.
 succeeds :: Matcher t ()
 succeeds = guard True
@@ -196,3 +202,4 @@ matchOne t (Comp g f)   = matchOne t f >>= \x -> matchOne x g
 matchOne _ (Pure a)     = pure a
 matchOne _ Empty        = empty
 matchOne t (Then m f)   = matchOne t m >>= matchOne t . f
+  matchOne t (Split f g)  = matchOne t id >>= \(a, b) -> (,) <$> matchOne a f <*> matchOne b g
diff --git a/src/Control/Rewriting.hs b/src/Control/Rewriting.hs
index 73e831d62..89f3a8629 100644
--- a/src/Control/Rewriting.hs
+++ b/src/Control/Rewriting.hs
@@ -376,9 +376,6 @@ paraM f = liftM snd . cataM run
           a <- f t
           pure (embed $ fmap fst t, a)
 
-eitherA :: Applicative f => (b -> f (Either a c)) -> Either a b -> f (Either a c)
-eitherA = either (pure . Left)
-
 -- | As 'rewriteM', but with some parameters reversed.
 runE :: forall m env from to . Monad m
      => env
diff --git a/src/Prologue.hs b/src/Prologue.hs
index ee174bfeb..a8e7bf277 100644
--- a/src/Prologue.hs
+++ b/src/Prologue.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 module Prologue
   ( module X
+  , eitherA
   , foldMapA
   , maybeM
   , maybeLast
@@ -72,3 +73,7 @@ fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just)
 -- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action.
 maybeM :: Applicative f => f a -> Maybe a -> f a
 maybeM f = maybe f pure
+
+-- Promote a function to either-applicatives.
+eitherA :: Applicative f => (b -> f (Either a c)) -> Either a b -> f (Either a c)
+eitherA = either (pure . Left)