From 1d6346cb64d50d80c20ad86867a23b358f6cae3c Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Mon, 6 Aug 2018 16:33:50 -0400
Subject: [PATCH] set ground for Control.Rule and Control.Rule.Engine

---
 semantic.cabal                     |  6 +++
 src/Control/Rule.hs                | 76 ++++++++++++++++++++++++++++++
 src/Control/Rule/Engine.hs         |  5 ++
 src/Control/Rule/Engine/Builtin.hs | 23 +++++++++
 src/Semantic/Util.hs               |  1 +
 5 files changed, 111 insertions(+)
 create mode 100644 src/Control/Rule.hs
 create mode 100644 src/Control/Rule/Engine.hs
 create mode 100644 src/Control/Rule/Engine/Builtin.hs

diff --git a/semantic.cabal b/semantic.cabal
index 699506698..7484630cd 100644
--- a/semantic.cabal
+++ b/semantic.cabal
@@ -47,6 +47,10 @@ library
                      , Control.Abstract.Roots
                      , Control.Abstract.TermEvaluator
                      , Control.Abstract.Value
+                     -- Interfaces to the process-based rule engine
+                     , Control.Rule
+                     , Control.Rule.Engine
+                     , Control.Rule.Engine.Builtin
                      -- Datatypes for abstract interpretation
                      , Data.Abstract.Address
                      , Data.Abstract.Cache
@@ -210,6 +214,7 @@ library
                      , http-client-tls
                      , http-types
                      , kdt
+                     , machines
                      , mersenne-random-pure64
                      , microlens
                      , mtl
@@ -220,6 +225,7 @@ library
                      , parsers
                      , prettyprinter
                      , pretty-show
+                     , profunctors
                      , recursion-schemes
                      , reducers
                      , scientific
diff --git a/src/Control/Rule.hs b/src/Control/Rule.hs
new file mode 100644
index 000000000..d18e4bec7
--- /dev/null
+++ b/src/Control/Rule.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-missing-export-lists #-}
+
+module Control.Rule where
+
+import Prologue
+
+import           Control.Monad.Effect (Eff, Effect, Effectful (..))
+import qualified Control.Monad.Effect as Eff
+import           Control.Monad.Effect.State
+import           Data.Coerce
+import           Data.Functor.Identity
+import           Data.Machine
+import           Data.Profunctor
+import           Data.Text (Text, intercalate, unpack)
+
+data Rule from to = Rule
+  { description :: [Text]
+  , machine     :: MachineT Identity (Is from) to
+  } deriving (Functor)
+
+instance Show (Rule from to) where
+  show = unpack . intercalate " | " . description
+
+instance Lower (Rule from to) where
+  lowerBound = Rule [] mempty
+
+instance Semigroup (Rule from to) where
+  (Rule a c) <> (Rule b d) = Rule (a <> b) (c <> d)
+
+data Previous a = After
+  { previous :: Maybe a
+  , current  :: a
+  } deriving (Show, Eq, Functor)
+
+fromMealy :: Text -> (Previous from -> to) -> Rule from to
+fromMealy t f = Rule [t] . auto $ unfoldMealy go initial where
+  initial = After Nothing (error shouldn'tHappen)
+  shouldn'tHappen = "bug: attempted to access an After before it was ready"
+  go acc from =
+    let into = acc  { current = from }
+        out  = into { previous = Just from }
+    in (f into, out)
+
+
+-- remembering :: Rule effs from (After from)
+-- remembering =
+
+
+
+-- instance Monoid (Rule effs from to) where
+--   mappend = (<>)
+--   mempty  = lowerBound
+
+-- -- instance Profunctor (Rule effs) where
+-- --   dimap f g (Rule t m) = Rule t _
+
+-- -- | This is a natural transformation between 'effs' and 'Identity'.
+-- -- type Purifier effs = forall a . Eff effs a -> a
+
+-- -- runRule :: Foldable f => (Eff effs a -> a) -> Rule effs from to -> f from -> [to]
+-- -- runRule p (Rule _ m) s = Eff.run .  . runT $ source s ~> m
+-- --p . snd . runState lowerBound . runT
+
+-- inside :: (forall a . Eff old a -> Eff new a) -> Rule old from to -> Rule new from to
+-- inside f (Rule d m) = Rule d (fitM f m)
+
+-- toProcess :: Effect (Union effs) => Rule effs from to -> ProcessT (Eff effs) from to
+-- toProcess = machine
+
+-- runRuleM :: (Effect (Union effs), Effectful m, Foldable f) => Rule effs from to -> f from -> m effs [to]
+-- runRuleM (Rule _ mach) src
+--   = raiseEff
+--   . runT $ source src ~> mach
diff --git a/src/Control/Rule/Engine.hs b/src/Control/Rule/Engine.hs
new file mode 100644
index 000000000..21216dd2e
--- /dev/null
+++ b/src/Control/Rule/Engine.hs
@@ -0,0 +1,5 @@
+module Control.Rule.Engine
+  ( module X
+  ) where
+
+import Control.Rule.Engine.Builtin as X
diff --git a/src/Control/Rule/Engine/Builtin.hs b/src/Control/Rule/Engine/Builtin.hs
new file mode 100644
index 000000000..67b3a59d2
--- /dev/null
+++ b/src/Control/Rule/Engine/Builtin.hs
@@ -0,0 +1,23 @@
+module Control.Rule.Engine.Builtin where
+
+import Control.Rule
+import Control.Monad.Reader
+import Data.Reprinting.Token
+
+checkSeparators :: Rule Token Token
+checkSeparators = fromMealy "Builtin: check separators" $
+  current <$> ask
+
+{-
+
+checkSeparators :: Rule Token Token
+checkSeparators = withPrevious "Builtin: check separator" $
+  inListContext $ do
+
+    ensure
+
+
+
+
+
+-}
diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs
index 218bce386..b1e5ef865 100644
--- a/src/Semantic/Util.hs
+++ b/src/Semantic/Util.hs
@@ -9,6 +9,7 @@ import           Analysis.Abstract.Collecting
 import           Control.Abstract
 import           Control.Exception (displayException)
 import           Control.Monad.Effect.Trace (runPrintingTrace)
+import           Control.Rule.Engine.Builtin
 import           Data.Abstract.Address
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Module