From aed9d74b0fb1911a9c21814281e8be05e2f9f433 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 7 Aug 2018 18:13:59 -0400
Subject: [PATCH] An Arrow instance for Rule.

---
 src/Control/Rule.hs                | 37 ++++++++++++++++++++++++------
 src/Control/Rule/Engine/Builtin.hs |  2 +-
 2 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/src/Control/Rule.hs b/src/Control/Rule.hs
index 289a5f08c..c3aaeecac 100644
--- a/src/Control/Rule.hs
+++ b/src/Control/Rule.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-missing-export-lists #-}
@@ -33,14 +33,28 @@ data Rule effs from to = Rule
   , machine     :: ProcessT (Eff effs) from to
   } deriving Functor
 
+-- As per the above, we may wish to do the following:
+
+-- data GRule input effs from to = GRule
+--   { description :: [Text]
+--   , machine :: MachineT (Eff effs) (k from) to
+--   }
+
+-- newtype Rule effs from to = Rule { unruly :: GRule Is effs from to }
+
 instance Category (Rule effs) where
-  id = Rule ["[builtin] echo"] echo
+  id = Rule ["[anonymous] Rule.Category.id"] echo
   Rule d p . Rule d' p' = Rule (d' <> d) (p' ~> p)
 
 instance Profunctor (Rule effs) where
   lmap f (Rule d p) = Rule d (auto f ~> p)
   rmap = fmap
 
+instance Arrow (Rule effs) where
+  arr = fromFunction "[anonymous] Rule.Arrow.arr"
+  (Rule d a) *** (Rule d' b)
+    = Rule (d <> d') (teeT zipping (auto fst ~> a) (auto snd ~> b))
+
 instance Show (Rule effs from to) where
   show = unpack . intercalate " | " . description
 
@@ -54,17 +68,26 @@ instance Monoid (Rule effs from to)   where
   mempty = lowerBound
   mappend = (<>)
 
-fromPlan :: Text -> PlanT (Is from) to (Eff effs) () -> Rule effs from to
+fromPlan :: Text -> PlanT (Is from) to (Eff effs) a -> Rule effs from to
 fromPlan desc plan = Rule [desc] (repeatedly plan)
 
-fromPlanState :: Lower state => Text -> (state -> PlanT (Is from) to (Eff effs) state) -> Rule effs from to
-fromPlanState t = Rule [t] . unfoldPlan lowerBound
+-- This function is not possible to write yet. It will take a refactor of Rule.
+-- fromPlan' :: Text -> PlanT k o (Eff effs) a -> GRule k effs from to
+
+fromStateful :: Lower state => Text -> (state -> PlanT (Is from) to (Eff effs) state) -> Rule effs from to
+fromStateful t = Rule [t] . unfoldPlan lowerBound
 
 fromFunction :: Text -> (from -> to) -> Rule effs from to
-fromFunction t f = fromEffect t (pure . f)
+fromFunction = fromAutomaton
 
 fromEffect :: Text -> (from -> Eff effs to) -> Rule effs from to
-fromEffect t = Rule [t] . autoT . Kleisli
+fromEffect t = fromAutomatonM t . Kleisli
+
+fromAutomaton :: (Automaton k) => Text -> k from to -> Rule effs from to
+fromAutomaton t = Rule [t] . auto
+
+fromAutomatonM :: AutomatonM k => Text -> k (Eff effs) from to -> Rule effs from to
+fromAutomatonM t = Rule [t] . autoT
 
 runRule :: Foldable f => f from -> Rule effs from to -> Eff effs [to]
 runRule inp r = runT (source inp ~> machine r)
diff --git a/src/Control/Rule/Engine/Builtin.hs b/src/Control/Rule/Engine/Builtin.hs
index 9f5e3fa8b..485cc9fda 100644
--- a/src/Control/Rule/Engine/Builtin.hs
+++ b/src/Control/Rule/Engine/Builtin.hs
@@ -28,7 +28,7 @@ newtype Previous a = Previous (Maybe a)
   deriving (Eq, Show, Functor, Applicative, Lower)
 
 remembering :: forall effs a . Rule effs a (Previous a, a)
-remembering = fromPlanState "[builtin] remembering" $ \prev -> do
+remembering = fromStateful "[builtin] remembering" $ \prev -> do
   x <- await
   yield (prev, x)
   pure (pure @Previous x)