Merge branch 'master' into add-php

semantic.cabal

@@ -56,7 +56,6 @@ common dependencies
                      , fused-effects-exceptions ^>= 0.1.1.0
                      , hashable ^>= 1.2.7.0
                      , tree-sitter ^>= 0.1.0.0
-                     , machines ^>= 0.6.4
                      , mtl ^>= 2.2.2
                      , network ^>= 2.8.0.0
                      , process ^>= 1.6.3.0
@@ -65,6 +64,7 @@ common dependencies
                      , safe-exceptions ^>= 0.1.7.0
                      , semilattices ^>= 0.0.0.3
                      , shelly >= 1.5 && <2
+                     , streaming ^>= 0.2.2.0
                      , text ^>= 1.2.3.1
                      , these >= 0.7 && <1
                      , unix ^>= 2.7.2.2
@@ -308,7 +308,6 @@ library
                      , profunctors ^>= 5.3
                      , reducers ^>= 3.12.3
                      , semigroupoids ^>= 5.3.2
-                     , servant ^>= 0.15
                      , split ^>= 0.2.3.3
                      , stm-chans ^>= 3.0.0.4
                      , template-haskell ^>= 2.14

src/Data/Language.hs

@@ -108,6 +108,7 @@ languageForType mediaType = case mediaType of
     ".rb"   -> Ruby
     ".go"   -> Go
     ".js"   -> JavaScript
+    ".mjs"  -> JavaScript
     ".ts"   -> TypeScript
     ".tsx"  -> TSX
     ".jsx"  -> JSX
@@ -120,7 +121,7 @@ extensionsForLanguage :: Language -> [String]
 extensionsForLanguage language = case language of
   Go         -> [".go"]
   Haskell    -> [".hs"]
-  JavaScript -> [".js"]
+  JavaScript -> [".js", ".mjs"]
   PHP        -> [".php", ".phpt"]
   Python     -> [".py"]
   Ruby       -> [".rb"]
@@ -134,7 +135,7 @@ languageForFilePath :: FilePath -> Language
 languageForFilePath = languageForType . takeExtension
 
 supportedExts :: [String]
-supportedExts = [".go", ".py", ".rb", ".js", ".ts", ".php", ".phpt"]
+supportedExts = [".go", ".py", ".rb", ".js", ".mjs", ".ts", ".php", ".phpt"]
 
 codeNavLanguages :: [Language]
 codeNavLanguages = [Go, Ruby, Python, JavaScript, TypeScript, PHP]

src/Data/Reprinting/Fragment.hs

@@ -7,8 +7,9 @@ module Data.Reprinting.Fragment
   , defer
   ) where
 
-import Data.Machine
 import Data.Text (Text)
+import Streaming
+import Streaming.Prelude (yield)
 
 import Data.Reprinting.Scope
 import Data.Reprinting.Token
@@ -25,13 +26,13 @@ data Fragment
   deriving (Eq, Show)
 
 -- | Copy along some original, un-refactored 'Text'.
-copy :: Text -> Plan k Fragment ()
+copy :: Monad m => Text -> Stream (Of Fragment) m ()
 copy = yield . Verbatim
 
 -- | Insert some new 'Text'.
-insert :: Element -> [Scope] -> Text -> Plan k Fragment ()
+insert :: Monad m => Element -> [Scope] -> Text -> Stream (Of Fragment) m ()
 insert el c = yield . New el c
 
 -- | Defer processing an element to a later stage.
-defer :: Element -> [Scope] -> Plan k Fragment ()
+defer :: Monad m => Element -> [Scope] -> Stream (Of Fragment) m ()
 defer el = yield . Defer el

src/Data/Reprinting/Splice.hs

@@ -18,7 +18,8 @@ module Data.Reprinting.Splice
 
 import Prologue hiding (Element)
 
-import Data.Machine
+import Streaming
+import Streaming.Prelude (yield)
 
 import Data.Reprinting.Fragment
 
@@ -29,29 +30,29 @@ data Splice
   deriving (Eq, Show)
 
 -- | Emit some 'Text' as a 'Splice'.
-emit :: Text -> Plan k Splice ()
+emit :: Monad m => Text -> Stream (Of Splice) m ()
 emit = yield . Emit
 
 -- | Emit the provided 'Text' if the given predicate is true.
-emitIf :: Bool -> Text -> Plan k Splice ()
+emitIf :: Monad m => Bool -> Text -> Stream (Of Splice) m ()
 emitIf p = when p . emit
 
 -- | Construct a layout 'Splice'.
-layout :: Whitespace -> Plan k Splice ()
+layout :: Monad m => Whitespace -> Stream (Of Splice) m ()
 layout = yield . Layout
 
 -- | @indent w n@ emits @w@ 'Spaces' @n@ times.
-indent :: Int -> Int -> Plan k Splice ()
+indent :: Monad m => Int -> Int -> Stream (Of Splice) m ()
 indent width times
   | times > 0 = replicateM_ times (layout (Indent width Spaces))
   | otherwise = pure ()
 
 -- | Construct multiple layouts.
-layouts :: [Whitespace] -> Plan k Splice ()
+layouts :: Monad m => [Whitespace] -> Stream (Of Splice) m ()
 layouts = traverse_ (yield . Layout)
 
 -- | Single space.
-space :: Plan k Splice ()
+space :: Monad m => Stream (Of Splice) m ()
 space = yield (Layout Space)
 
 -- | Indentation, spacing, and other whitespace.

src/Language/JSON/PrettyPrint.hs

@@ -8,32 +8,35 @@ module Language.JSON.PrettyPrint
 
 import Prologue
 
-import Control.Effect
-import Control.Effect.Error
-import Control.Monad.Trans (lift)
-import Data.Machine
+import           Control.Effect
+import           Control.Effect.Error
+import           Streaming
+import qualified Streaming.Prelude as Streaming
 
 import Data.Reprinting.Errors
+import Data.Reprinting.Scope
 import Data.Reprinting.Splice
 import Data.Reprinting.Token
-import Data.Reprinting.Scope
 
 -- | Default printing pipeline for JSON.
 defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m)
-  => ProcessT m Fragment Splice
+                    => Stream (Of Fragment) m a
+                    -> Stream (Of Splice) m a
 defaultJSONPipeline
-  = printingJSON
-  ~> beautifyingJSON defaultBeautyOpts
+  = beautifyingJSON defaultBeautyOpts
+  . printingJSON
 
 -- | Print JSON syntax.
-printingJSON :: Monad m => ProcessT m Fragment Fragment
-printingJSON = repeatedly (await >>= step) where
+printingJSON :: Monad m
+             => Stream (Of Fragment) m a
+             -> Stream (Of Fragment) m a
+printingJSON = Streaming.map step where
   step s@(Defer el cs) =
-    let ins = yield . New el cs
+    let ins = New el cs
     in case (el, listToMaybe cs) of
-      (Truth True, _)      -> ins "true"
-      (Truth False, _)     -> ins "false"
-      (Nullity, _)         -> ins "null"
+      (Truth True, _)    -> ins "true"
+      (Truth False, _)   -> ins "false"
+      (Nullity, _)       -> ins "null"
 
       (Open,  Just List) -> ins "["
       (Close, Just List) -> ins "]"
@@ -44,8 +47,8 @@ printingJSON = repeatedly (await >>= step) where
       (Sep, Just Pair)   -> ins ":"
       (Sep, Just Hash)   -> ins ","
 
-      _                    -> yield s
-  step x = yield x
+      _                  -> s
+  step x = x
 
 -- TODO: Fill out and implement configurable options like indentation count,
 -- tabs vs. spaces, etc.
@@ -57,9 +60,11 @@ defaultBeautyOpts = JSONBeautyOpts 2 False
 
 -- | Produce JSON with configurable whitespace and layout.
 beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m)
-  => JSONBeautyOpts -> ProcessT m Fragment Splice
-beautifyingJSON _ = repeatedly (await >>= step) where
-  step (Defer el cs)   = lift (throwError (NoTranslation el cs))
+                => JSONBeautyOpts
+                -> Stream (Of Fragment) m a
+                -> Stream (Of Splice) m a
+beautifyingJSON _ s = Streaming.for s step where
+  step (Defer el cs)   = effect (throwError (NoTranslation el cs))
   step (Verbatim txt)  = emit txt
   step (New el cs txt) = case (el, cs) of
     (Open,  Hash:_)    -> emit txt *> layout HardWrap *> indent 2 (hashDepth cs)
@@ -67,13 +72,14 @@ beautifyingJSON _ = repeatedly (await >>= step) where
     (Sep,   List:_)    -> emit txt *> space
     (Sep,   Pair:_)    -> emit txt *> space
     (Sep,   Hash:_)    -> emit txt *> layout HardWrap *> indent 2 (hashDepth cs)
-    _                    -> emit txt
+    _                  -> emit txt
 
 -- | Produce whitespace minimal JSON.
 minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m)
-  => ProcessT m Fragment Splice
-minimizingJSON = repeatedly (await >>= step) where
-  step (Defer el cs)  = lift (throwError (NoTranslation el cs))
+               => Stream (Of Fragment) m a
+               -> Stream (Of Splice) m a
+minimizingJSON s = Streaming.for s step where
+  step (Defer el cs)  = effect (throwError (NoTranslation el cs))
   step (Verbatim txt) = emit txt
   step (New _ _ txt)  = emit txt
 

src/Language/Python/PrettyPrint.hs

@@ -4,8 +4,8 @@ module Language.Python.PrettyPrint ( printingPython ) where
 
 import Control.Effect
 import Control.Effect.Error
-import Control.Monad.Trans (lift)
-import Data.Machine
+import Streaming
+import qualified Streaming.Prelude as Streaming
 
 import Data.Reprinting.Errors
 import Data.Reprinting.Splice
@@ -14,10 +14,12 @@ import Data.Reprinting.Scope
 import Data.Reprinting.Operator
 
 -- | Print Python syntax.
-printingPython :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice
-printingPython = repeatedly (await >>= step)
+printingPython :: (Member (Error TranslationError) sig, Carrier sig m)
+               => Stream (Of Fragment) m a
+               -> Stream (Of Splice) m a
+printingPython s = Streaming.for s step
 
-step :: (Member (Error TranslationError) sig, Carrier sig m) => Fragment -> PlanT k Splice m ()
+step :: (Member (Error TranslationError) sig, Carrier sig m) => Fragment -> Stream (Of Splice) m ()
 step (Verbatim txt) = emit txt
 step (New _ _ txt)  = emit txt
 step (Defer el cs)  = case (el, cs) of
@@ -63,7 +65,7 @@ step (Defer el cs)  = case (el, cs) of
   (Sep,   Imperative:xs)        -> layout HardWrap *> indent 4 (imperativeDepth xs)
   (Close, Imperative:_)         -> pure ()
 
-  _                              -> lift (throwError (NoTranslation el cs))
+  _                             -> effect (throwError (NoTranslation el cs))
 
   where
     endContext times = layout HardWrap *> indent 4 (pred times)

src/Language/Ruby/PrettyPrint.hs

@@ -5,7 +5,8 @@ module Language.Ruby.PrettyPrint ( printingRuby ) where
 import Control.Effect
 import Control.Effect.Error
 import Control.Monad.Trans (lift)
-import Data.Machine
+import Streaming
+import qualified Streaming.Prelude as Streaming
 
 import Data.Reprinting.Scope
 import Data.Reprinting.Errors
@@ -14,10 +15,14 @@ import Data.Reprinting.Splice
 import Data.Reprinting.Token as Token
 
 -- | Print Ruby syntax.
-printingRuby :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice
-printingRuby = repeatedly (await >>= step)
+printingRuby :: (Member (Error TranslationError) sig, Carrier sig m)
+             => Stream (Of Fragment) m a
+             -> Stream (Of Splice) m a
+printingRuby s = Streaming.for s step
 
-step :: (Member (Error TranslationError) sig, Carrier sig m) => Fragment -> PlanT k Splice m ()
+step :: (Member (Error TranslationError) sig, Carrier sig m)
+     => Fragment
+     -> Stream (Of Splice) m ()
 step (Verbatim txt) = emit txt
 step (New _ _ txt)  = emit txt
 step (Defer el cs)  = case (el, cs) of
@@ -47,9 +52,9 @@ step (Defer el cs)  = case (el, cs) of
   (Close, [Imperative])         -> layout HardWrap
   (Close, Imperative:xs)        -> indent 2 (pred (imperativeDepth xs))
 
-  (Sep, Call:_)                -> emit "."
+  (Sep, Call:_)                 -> emit "."
 
-  _                              -> lift (throwError (NoTranslation el cs))
+  _                             -> effect (throwError (NoTranslation el cs))
 
   where
     endContext times = layout HardWrap *> indent 2 (pred times)

src/Reprinting/Pipeline.hs

@@ -95,7 +95,7 @@ stages of the pipeline follows:
 
 -}
 
-{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables, RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables #-}
 module Reprinting.Pipeline
   ( runReprinter
   , runTokenizing
@@ -106,10 +106,10 @@ module Reprinting.Pipeline
 import           Control.Effect as Effect
 import           Control.Effect.Error as Effect
 import           Control.Effect.State as Effect
-import           Data.Machine hiding (Source)
-import           Data.Machine.Runner
 import           Data.Text.Prettyprint.Doc
 import           Data.Text.Prettyprint.Doc.Render.Text
+import           Streaming
+import qualified Streaming.Prelude as Streaming
 
 import           Data.Reprinting.Errors
 import           Data.Reprinting.Scope
@@ -121,57 +121,58 @@ import           Reprinting.Tokenize
 import           Reprinting.Translate
 import           Reprinting.Typeset
 
-
--- | Run the reprinting pipeline given the original 'Source', a language
--- specific machine (`ProcessT`) and the provided 'Term'.
+-- | Run the reprinting pipeline given the original 'Source', a language specific
+-- translation function (as a function over 'Stream's) and the provided 'Term'.
 runReprinter :: Tokenize a
-  => Source.Source
-  -> ProcessT Translator Fragment Splice
-  -> Term a History
-  -> Either TranslationError Source.Source
-runReprinter src translating tree
+             => Source.Source
+             -> (Stream (Of Fragment) TranslatorC () -> Stream (Of Splice) TranslatorC ())
+             -> Term a History
+             -> Either TranslationError Source.Source
+runReprinter src translating
   = fmap go
   . Effect.run
   . Effect.runError
-  . fmap snd
-  . runState (mempty :: [Scope])
-  . foldT $ source (tokenizing src tree)
-      ~> contextualizing
-      ~> translating
-      ~> typesetting
+  . evalState @[Scope] mempty
+  . Streaming.mconcat_
+  . typesetting
+  . translating
+  . contextualizing
+  . tokenizing src
   where go = Source.fromText . renderStrict . layoutPretty defaultLayoutOptions
 
 -- | Run the reprinting pipeline up to tokenizing.
 runTokenizing :: Tokenize a
-  => Source.Source
-  -> Term a History
-  -> [Token]
-runTokenizing src tree
-  = Data.Machine.run $ source (tokenizing src tree)
+              => Source.Source
+              -> Term a History
+              -> [Token]
+runTokenizing src
+  = runIdentity
+  . Streaming.toList_
+  . tokenizing src
 
 -- | Run the reprinting pipeline up to contextualizing.
 runContextualizing :: Tokenize a
-  => Source.Source
-  -> Term a History
-  -> Either TranslationError [Fragment]
-runContextualizing src tree
+                   => Source.Source
+                   -> Term a History
+                   -> Either TranslationError [Fragment]
+runContextualizing src
   = Effect.run
   . Effect.runError
-  . fmap snd
-  . runState (mempty :: [Scope])
-  . runT $ source (tokenizing src tree)
-      ~> contextualizing
+  . evalState @[Scope] mempty
+  . Streaming.toList_
+  . contextualizing
+  . tokenizing src
 
 runTranslating :: Tokenize a
-  => Source.Source
-  -> ProcessT Translator Fragment Splice
-  -> Term a History
-  -> Either TranslationError [Splice]
-runTranslating src translating tree
+               => Source.Source
+               -> (Stream (Of Fragment) TranslatorC () -> Stream (Of Splice) TranslatorC ())
+               -> Term a History
+               -> Either TranslationError [Splice]
+runTranslating src translating
   = Effect.run
   . Effect.runError
-  . fmap snd
-  . runState (mempty :: [Scope])
-  . runT $ source (tokenizing src tree)
-      ~> contextualizing
-      ~> translating
+  . evalState @[Scope] mempty
+  . Streaming.toList_
+  . translating
+  . contextualizing
+  . tokenizing src

src/Reprinting/Tokenize.hs

@@ -29,10 +29,11 @@ module Reprinting.Tokenize
 
 import Prelude hiding (fail, log, filter)
 import Prologue hiding (Element, hash)
+import Streaming hiding (Sum)
+import qualified Streaming.Prelude as Streaming
 
 import           Data.History
 import           Data.List (intersperse)
-import qualified Data.Machine as Machine
 import           Data.Range
 import           Data.Reprinting.Scope (Scope)
 import qualified Data.Reprinting.Scope as Scope
@@ -55,15 +56,14 @@ data Tokenizer a where
   Get :: Tokenizer State
   Put :: State -> Tokenizer ()
 
--- Tokenizers are compiled into a Plan capable of being converted
--- to a Source. Note that the state parameter is internal to the
--- tokenizer being run: the invoker of 'tokenizing' doesn't need
--- to keep track of it at all.
-compile :: State -> Tokenizer a -> Machine.Plan k Token (State, a)
+-- Tokenizers are compiled directly into Stream values. Note that the
+-- state parameter is internal to the tokenizer being run: the invoker
+-- of 'tokenizing' doesn't need to keep track of it at all.
+compile :: Monad m => State -> Tokenizer a -> Stream (Of Token) m (State, a)
 compile p = \case
   Pure a   -> pure (p, a)
   Bind a f -> compile p a >>= (\(new, v) -> compile new (f v))
-  Tell t   -> Machine.yield t $> (p, ())
+  Tell t   -> Streaming.yield t $> (p, ())
   Get      -> pure (p, p)
   Put p'   -> pure (p', ())
 
@@ -229,12 +229,12 @@ class (Show1 constr, Traversable constr) => Tokenize constr where
   -- | Should emit control and data tokens.
   tokenize :: FAlgebra constr (Tokenizer ())
 
-tokenizing :: Tokenize a
+tokenizing :: (Monad m, Tokenize a)
            => Source
            -> Term a History
-           -> Machine.Source Token
+           -> Stream (Of Token) m ()
 tokenizing src term = pipe
-  where pipe  = Machine.construct . fmap snd $ compile state go
+  where pipe  = fmap snd $ compile state go
         state = State src (termAnnotation term) Reprinting 0 ForbidData
         go    = forbidData *> foldSubterms descend term <* finish
 

src/Reprinting/Translate.hs

@@ -1,42 +1,50 @@
 {-# LANGUAGE LambdaCase #-}
 
 module Reprinting.Translate
-  ( Translator
-  , contextualizing
+  ( contextualizing
+  , TranslatorC
   ) where
 
-import           Control.Monad
 import           Control.Effect
 import           Control.Effect.Error
 import           Control.Effect.State
-import           Control.Monad.Trans
-import           Data.Machine
+import           Control.Monad
+import           Streaming
+import qualified Streaming.Prelude as Streaming
 
 import           Data.Reprinting.Errors
+import           Data.Reprinting.Scope
 import           Data.Reprinting.Splice
 import           Data.Reprinting.Token
-import           Data.Reprinting.Scope
 import qualified Data.Source as Source
 
-type Translator
+type TranslatorC
   = StateC [Scope]
   ( ErrorC TranslationError PureC)
 
-contextualizing :: ProcessT Translator Token Fragment
-contextualizing = repeatedly $ await >>= \case
-  Chunk source -> yield . Verbatim . Source.toText $ source
-  Element t -> case t of
-    Run f -> lift get >>= \c -> yield (New t c f)
-    _     -> lift get >>= yield . Defer t
-  Control ctl -> case ctl of
+contextualizing :: Stream (Of Token) TranslatorC a
+                -> Stream (Of Fragment) TranslatorC a
+contextualizing = Streaming.mapMaybeM $ \case
+  Chunk source -> pure . Just . Verbatim . Source.toText $ source
+  Element t -> Just <$> case t of
+    Run f -> get >>= \c -> pure (New t c f)
+    _     -> get >>= pure . Defer t
+  Control ctl -> Nothing <$ case ctl of
     Enter c -> enterScope c
     Exit c  -> exitScope c
     _       -> pure ()
 
-enterScope, exitScope :: Scope -> PlanT k Fragment Translator ()
+enterScope :: (Member (State [Scope]) sig, Carrier sig m)
+           => Scope
+           -> m ()
+enterScope c = modify (c :)
 
-enterScope c = lift (modify (c :))
-
-exitScope c = lift get >>= \case
-  (x:xs) -> when (x == c) (lift (modify (const xs)))
-  cs     -> lift (throwError (UnbalancedPair c cs))
+exitScope :: ( Member (State [Scope]) sig
+             , Member (Error TranslationError) sig
+             , Carrier sig m
+             )
+          => Scope
+          -> m ()
+exitScope c = get >>= \case
+  (x:xs) -> when (x == c) (put xs)
+  cs     -> throwError (UnbalancedPair c cs)

src/Reprinting/Typeset.hs

@@ -5,12 +5,14 @@ module Reprinting.Typeset
 
 import Prologue
 
-import Data.Machine
+import Streaming
+import qualified Streaming.Prelude as Streaming
 import Data.Reprinting.Splice hiding (space)
 import Data.Text.Prettyprint.Doc
 
-typesetting :: Monad m => ProcessT m Splice (Doc a)
-typesetting = auto step
+typesetting :: Monad m => Stream (Of Splice) m x
+                       -> Stream (Of (Doc a)) m x
+typesetting = Streaming.map step
 
 step :: Splice -> Doc a
 step (Emit t)                   = pretty t
@@ -23,8 +25,10 @@ step (Layout (Indent 0 Tabs))   = mempty
 step (Layout (Indent n Tabs))   = stimes n "\t"
 
 -- | Typeset, but show whitespace with printable characters for debugging purposes.
-typesettingWithVisualWhitespace :: Monad m => ProcessT m Splice (Doc a)
-typesettingWithVisualWhitespace = auto step where
+typesettingWithVisualWhitespace :: Monad m
+                                => Stream (Of Splice) m x
+                                -> Stream (Of (Doc a)) m x
+typesettingWithVisualWhitespace = Streaming.map step where
   step :: Splice -> Doc a
   step (Emit t)                   = pretty t
   step (Layout SoftWrap)          = softline

src/Tags/Taggable.hs

@@ -28,14 +28,15 @@ import Analysis.HasTextElement
 import Data.Abstract.Declarations
 import Data.Abstract.Name
 import Data.Blob
-import Data.Functor.Identity
 import Data.Language
 import Data.Location
-import Data.Machine as Machine
 import Data.Range
 import Data.Term
 import Data.Text hiding (empty)
 
+import Streaming hiding (Sum)
+import Streaming.Prelude (yield)
+
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
@@ -63,13 +64,13 @@ data Token
   | Iden  { identifierName :: Text, tokenSpan :: Span, docsLiteralRange :: Maybe Range }
   deriving (Eq, Show)
 
-type Tagger k a = PlanT k Token Identity a
+type Tagger = Stream (Of Token)
 
-enter, exit :: String -> Maybe Range -> Tagger k ()
+enter, exit :: Monad m => String -> Maybe Range -> Tagger m ()
 enter c = yield . Enter (pack c)
 exit c = yield . Exit (pack c)
 
-emitIden :: Span -> Maybe Range -> Name -> Tagger k ()
+emitIden :: Monad m => Span -> Maybe Range -> Name -> Tagger m ()
 emitIden span docsLiteralRange name = yield (Iden (formatName name) span docsLiteralRange)
 
 class (Show1 constr, Traversable constr) => Taggable constr where
@@ -98,11 +99,11 @@ type IsTaggable syntax =
   , HasTextElement syntax
   )
 
-tagging :: (IsTaggable syntax)
+tagging :: (Monad m, IsTaggable syntax)
         => Blob
         -> Term syntax Location
-        -> Machine.MachineT Identity k Token
-tagging b = Machine.construct . foldSubterms (descend (blobLanguage b))
+        -> Stream (Of Token) m ()
+tagging b = foldSubterms (descend (blobLanguage b))
 
 descend ::
   ( Taggable (TermF syntax Location)
@@ -111,8 +112,9 @@ descend ::
   , Foldable syntax
   , HasTextElement syntax
   , Declarations1 syntax
+  , Monad m
   )
-  => Language -> SubtermAlgebra (TermF syntax Location) (Term syntax Location) (Tagger k ())
+  => Language -> SubtermAlgebra (TermF syntax Location) (Term syntax Location) (Tagger m ())
 descend lang t@(In loc _) = do
   let term = fmap subterm t
   let snippetRange = snippet loc term

src/Tags/Tagging.hs

@@ -10,26 +10,28 @@ import Prologue hiding (Element, hash)
 
 import           Control.Effect as Eff
 import           Control.Effect.State
-import           Control.Monad.Trans
+import           Data.Text as T hiding (empty)
+import           Streaming
+import qualified Streaming.Prelude as Streaming
+
 import           Data.Blob
 import           Data.Location
-import           Data.Machine as Machine
 import qualified Data.Source as Source
 import           Data.Tag
 import           Data.Term
-import           Data.Text as T hiding (empty)
 import           Tags.Taggable
 
 runTagging :: (IsTaggable syntax)
-  => Blob
-  -> [Text]
-  -> Term syntax Location
-  -> [Tag]
-runTagging blob symbolsToSummarize tree
+           => Blob
+           -> [Text]
+           -> Term syntax Location
+           -> [Tag]
+runTagging blob symbolsToSummarize
   = Eff.run
   . evalState @[ContextToken] []
-  . runT $ source (tagging blob tree)
-      ~> contextualizing blob symbolsToSummarize
+  . Streaming.toList_
+  . contextualizing blob symbolsToSummarize
+  . tagging blob
 
 type ContextToken = (Text, Maybe Range)
 
@@ -38,16 +40,17 @@ contextualizing :: ( Member (State [ContextToken]) sig
                    )
                 => Blob
                 -> [Text]
-                -> Machine.ProcessT m Token Tag
-contextualizing Blob{..} symbolsToSummarize = repeatedly $ await >>= \case
-  Enter x r -> lift (enterScope (x, r))
-  Exit  x r -> lift (exitScope (x, r))
-  Iden iden span docsLiteralRange -> lift (get @[ContextToken]) >>= \case
+                -> Stream (Of Token) m a
+                -> Stream (Of Tag) m a
+contextualizing Blob{..} symbolsToSummarize = Streaming.mapMaybeM $ \case
+  Enter x r -> Nothing <$ enterScope (x, r)
+  Exit  x r -> Nothing <$ exitScope (x, r)
+  Iden iden span docsLiteralRange -> get @[ContextToken] >>= pure . \case
     ((x, r):("Context", cr):xs) | x `elem` symbolsToSummarize
-      -> yield $ Tag iden x span (fmap fst xs) (firstLine (slice r)) (slice cr)
+      -> Just $ Tag iden x span (fmap fst xs) (firstLine (slice r)) (slice cr)
     ((x, r):xs) | x `elem` symbolsToSummarize
-      -> yield $ Tag iden x span (fmap fst xs) (firstLine (slice r)) (slice docsLiteralRange)
-    _ -> pure ()
+      -> Just $ Tag iden x span (fmap fst xs) (firstLine (slice r)) (slice docsLiteralRange)
+    _ -> Nothing
   where
     slice = fmap (stripEnd . Source.toText . flip Source.slice blobSource)
     firstLine = fmap (T.take 180 . fst . breakOn "\n")

test/Reprinting/Spec.hs

@@ -5,7 +5,8 @@ module Reprinting.Spec (spec) where
 import SpecHelpers
 
 import           Data.Foldable
-import qualified Data.Machine as Machine
+import           Streaming hiding (Sum)
+import qualified Streaming.Prelude as Streaming
 
 import           Control.Rewriting
 import qualified Data.Language as Language
@@ -35,13 +36,13 @@ spec = describe "reprinting" $ do
 
       it "should pass over a pristine tree" $ do
         let tagged = mark Unmodified tree
-        let toks = Machine.run $ tokenizing src tagged
+        let toks = runIdentity . Streaming.toList_ $ tokenizing src tagged
         toks `shouldSatisfy` not . null
         head toks `shouldSatisfy` isControl
         last toks `shouldSatisfy` isChunk
 
       it "should emit control tokens but only 1 chunk for a wholly-modified tree" $ do
-        let toks = Machine.run $ tokenizing src (mark Refactored tree)
+        let toks = runIdentity . Streaming.toList_ $ tokenizing src (mark Refactored tree)
         for_ @[] [List, Hash] $ \t -> do
           toks `shouldSatisfy` elem (Control (Enter t))
           toks `shouldSatisfy` elem (Control (Exit t))