Remove Rule

semantic.cabal

@@ -46,10 +46,6 @@ 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.Hole
                      , Data.Abstract.Address.Located
@@ -157,7 +153,6 @@ library
                      , Parsing.Parser
                      , Parsing.TreeSitter
                      , Paths_semantic
-                     , Refactoring.Core
                      -- Rendering formats
                      , Rendering.Graph
                      , Rendering.JSON

src/Control/Rule.hs

@@ -1,156 +0,0 @@
-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, LambdaCase #-}
-
--- | The fundamental data type representing steps in a rewrite rule
--- from @from@ data to @to@ data. A Rule may never emit data, or it
--- might filter data, or it might be a 1:1 mapping from input to
--- output. A rule can access state and other side effects through the
--- @effs@ parameter.
---
--- We use 'Rule's to build composable, constant-space pipelines for
--- streams of 'Token's; during the reprinting process, various
--- invariants may not be held over a token stream, and we can often
--- fix these invariants with simple state/stack machines. Indeed, in
--- this context a 'Rule' becomes a 'MachineT' with an effects list
--- inside it. In this sense, 'Rule's are similar to Bagge & Hasu's
--- concept of "rule-based token processors".
---
--- However, 'Rule's have a different purpose in the context of syntax
--- trees, rather than token streams: they are (well, will be)
--- convertible to a 'SubtermAlgebra' over a given 'Sum' type. In this
--- context, they are much more similar to the @Transform@ type from
--- the KURE rewriting system. Similarly, a 'Rule' from the matching
--- DSL should be convertible into a 'Rule'.
-
-module Control.Rule
-  ( Rule
-  , description
-  , machine
-  -- * Constructing rules
-  , fromPlan
-  , fromStateful
-  , fromEffect
-  , fromAutomatonM
-  , fromAutomaton
-  , fromFunction
-  , fromMatcher
-  , toAlgebra
-  , runRule
-  ) where
-
-import Prelude hiding ((.), id)
-import Prologue
-
-import           Control.Arrow
-import           Control.Category
-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.Machine.Runner
-import           Data.Profunctor
-import           Data.Text (Text, intercalate, unpack)
-
-import Control.Abstract.Matching
-
-
--- | A 'Rule' is a simple wrapper around the 'ProcessT' type from
--- @machines@. As such, it limits the input type of tokens to the
--- 'Is' carrier type, which might not be sufficiently flexible.
--- We may want to use 'MachineT' and make the machine's input
--- language explicit in the type of Rule:
--- @
---   data RuleC input effs from to = GRule
---     { description :: [Text]
---     , machine :: MachineT (Eff effs) (k from) to
---     }
---
---  type Rule = RuleC Is
--- @
---
--- This would allow us to use 'T' and 'Stack' in rules, which would be
--- pretty slick.
-data Rule effs from to = Rule
-  { description :: [Text]
-  , machine     :: ProcessT (Eff effs) from to
-  } deriving Functor
-
--- | The identity (pass-through) rule is 'id'. To compose 'Rule's
--- sequentially, use the `(>>>)` and `(<<<)` operators from
--- Control.Arrow.
-instance Category (Rule effs) where
-  id = Rule ["[anonymous] Rule.Category.id"] echo
-  Rule d p . Rule d' p' = Rule (d' <> d) (p' ~> p)
-
--- | You can contravariantly map over the 'from' parameter and
--- covariantly map over the 'to' with 'lmap' and 'rmap' respectively
-instance Profunctor (Rule effs) where
-  lmap f (Rule d p) = Rule d (auto f ~> p)
-  rmap = fmap
-
--- | You can use the Arrow combinators, or @-XArrows@ if you're really
--- feeling it.
-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 ArrowChoice (Rule effs) where
-  left l = fromPlan "left" go >>> rmap Left l where
-    go = await >>= either yield (const (return ()))
-
--- | Rules contain 'description' values. They will generally have
--- at least one description, and will attempt, when composed, to yield
--- a list of descriptions that describes the composition to some degree.
-instance Show (Rule effs from to) where
-  show = unpack . intercalate " | " . description
-
--- | The empty 'Rule' is 'stopped' and does not accept any input.
-instance Lower (Rule effs from to) where
-  lowerBound = Rule ["[anonymous] lowerBound"] mempty
-
--- | Left-to-right composition.
-instance Semigroup (Rule effs from to) where
-  (Rule a c) <> (Rule b d) = Rule (a <> b) (c <> d)
-
-instance Monoid (Rule effs from to)   where
-  mempty = lowerBound
-  mappend = (<>)
-
-
--- | Build a 'Rule' from a description and a 'Plan'.  Plans allow you
--- to 'await' zero or more values from upstream and 'yield' zero or
--- more values downstream.  You can 'lift' effectful actions into
--- 'PlanT'.
-fromPlan :: Text -> PlanT (Is from) to (Eff effs) a -> Rule effs from to
-fromPlan desc plan = Rule [desc] (repeatedly plan)
-
-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 = fromAutomaton
-
-fromEffect :: Text -> (from -> Eff effs to) -> Rule effs from to
-fromEffect t = fromAutomatonM t . Kleisli
-
-fromAutomaton :: Automaton k => Text -> k from to -> Rule effs from to
-fromAutomaton t = Rule [t] . auto
-
-fromMatcher :: Text -> Matcher from to -> Rule effs from (Either from (from, to))
-fromMatcher t m = Rule [t] (auto go) where go x = maybe (Left x) (\y -> Right (x, y)) (runOnce x m)
-
-fromAutomatonM :: AutomatonM k => Text -> k (Eff effs) from to -> Rule effs from to
-fromAutomatonM t = Rule [t] . autoT
-
-toAlgebra :: (Traversable (Base t), Corecursive t)
-          => Rule effs t t
-          -> FAlgebra (Base t) (Eff effs t)
-toAlgebra (Rule _ m) t = do
-  inner <- sequenceA t
-  res <- runT1 (source (Just (embed inner)) ~> m)
-  pure (fromMaybe (embed inner) res)
-
-runRule :: Foldable f => f from -> Rule effs from to -> Eff effs [to]
-runRule inp r = runT (source inp ~> machine r)

src/Control/Rule/Engine.hs

@@ -1,5 +0,0 @@
-module Control.Rule.Engine
-  ( module X
-  ) where
-
-import Control.Rule.Engine.Builtin as X

src/Control/Rule/Engine/Builtin.hs

@@ -1,137 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiWayIf, RankNTypes, ScopedTypeVariables, TupleSections, TypeFamilies #-}
-
-module Control.Rule.Engine.Builtin where
-
-import Prologue
-
-import Control.Arrow
-import           Control.Monad.Effect (Member)
-import qualified Control.Monad.Effect as Eff
-import           Control.Monad.Effect.State
-import           Control.Monad.Trans
-import           Control.Rule
-import           Data.Machine
-import qualified Data.Machine as Machine
-import           Data.Reprinting.Token
-
-trackingContexts :: Member (State [Context]) effs
-                 => Rule effs Token (Token, [Context])
-trackingContexts = fromPlan "[builtin] trackingContexts" $ do
-  t <- await
-  let go = yield =<< ((,) <$> pure t <*> lift get)
-  case t of
-    TControl (Enter e) -> go *> lift (modify' @[Context] (e :))
-    TControl (Exit _)  -> go <* lift (modify' @[Context] (drop 1))
-    _                  -> go
-
-newtype Previous a = Previous (Maybe a)
-  deriving (Eq, Show, Functor, Applicative, Lower)
-
-remembering :: forall effs a . Rule effs a (Previous a, a)
-remembering = fromStateful "[builtin] remembering" $ \prev -> do
-  x <- await
-  yield (prev, x)
-  pure (pure @Previous x)
-
-fixingHashes :: Rule effs (Previous (Token, [Context]), (Token, [Context])) Token
-fixingHashes = fromPlan "[builtin] fixing hashes" $ do
-  (Previous last, (current, context)) <- await
-
-  let isSeparator = fmap fst last == Just (TElement Separator)
-  -- TODO: check for trailing chunks
-
-  if
-    | listToMaybe context /= Just Associative -> yield current
-    | isNothing last -> yield current
-    | isSeparator    -> yield current
-    | otherwise      -> yield (TElement Separator) *> yield current
-
-fixingPipeline :: (Member (State [Context]) effs) => Rule effs Token Token
-fixingPipeline = trackingContexts >>> remembering >>> fixingHashes
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-runContextually :: (Foldable f, effs ~ '[State [Context], State (Previous from)])
-                => f from
-                -> Rule effs from to
-                -> [to]
-runContextually fs r
-  = Eff.run
-  . fmap snd
-  . runState (lowerBound @(Previous _))
-  . fmap snd
-  . runState ([] :: [Context])
-  . Machine.runT
-  $ source fs ~> machine r
-
-{-
-
-justs :: Monad m => Rule m (Maybe it) it
-justs = fromPlan "[builtin] justs" $
-  await >>= maybe (pure ()) yield
-
-data Trail from to = Trail
-  { tcurrent  :: ~from
-  , previous :: Maybe to
-  }
-
-remembering :: Monad m => (Trail from to -> to) -> Rule m from to
-remembering f = Rule ["[builtin] remembering"] pipeline where
-  pipeline = fold go initial ~> repeatedly filt
-  initial  = Trail (error "invalid Trail access") Nothing
-  filt = await @Is >>= maybeYield . previous
-  go acc item =
-    let
-      stepped = acc { tcurrent = item }
-      result  = f acc
-    in stepped { previous = Just result }
-
-data With ann from = With
-  { additional :: ann
-  , wcurrent   :: from
-  } deriving (Show, Eq)
-
-contextuallyP :: (Member (State [Context]) effs)
-              => PlanT
-                 (Is Token)
-                 (With [Context] Token)
-                 (Eff effs)
-                 ()
-contextuallyP = do
-  t <- await
-  case t of
-    TControl (Enter e) -> lift (modify' @[Context] (e :))
-    TControl (Exit _)  -> lift (modify' @[Context] (drop 1))
-    _                  -> traceM (show t)
-
-  st <- lift get
-  yield (With st t)
-
-contextually :: (Member (State [Context]) effs)
-             => Rule (Eff effs) Token (With [Context] Token)
-contextually = Rule ["[builtin] contextually"] (repeatedly contextuallyP)
-
--- contextually :: Monad m => Rule m Token (With [Context] Token)
--- contextually = do
---   t <- await
-
---   fromPlan "[builtin] contextually" $ do
--}

src/Refactoring/Core.hs

@@ -1,32 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
-
-module Refactoring.Core where
-
-import Prologue
-
-import Data.History
-import Data.Term
-import Data.Record
-
-history :: (Annotated t (Record fields), HasField fields History) => t -> History
-history = getField . annotation
-
--- ensureAccurateHistory :: ( term ~ Term s (Record fields)
---                          , Functor s
---                          , Foldable s
---                          , HasField fields History
---                          )
---                       => term -> term
--- ensureAccurateHistory t = foldSubterms historically t (history t)
---
--- historically :: ( term ~ Term s (Record fields)
---                 , Functor s
---                 , Foldable s
---                 , HasField fields History
---                 )
---              => SubtermAlgebra (Base term) term (History -> term)
--- historically f h
---   = embed (bimap (flip setField newHistory) extractTerm f) where
---     extractTerm (Subterm t c) = c . history $ t
---     childHistories = fmap (history . extractTerm) (toList f)
---     newHistory = revise h childHistories