diff --git a/semantic.cabal b/semantic.cabal index 7e0ffd623..f737fd836 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Data/Reprinting/Fragment.hs b/src/Data/Reprinting/Fragment.hs index c92a0c833..353ed2edf 100644 --- a/src/Data/Reprinting/Fragment.hs +++ b/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 diff --git a/src/Data/Reprinting/Splice.hs b/src/Data/Reprinting/Splice.hs index 56230f14a..7e1720d94 100644 --- a/src/Data/Reprinting/Splice.hs +++ b/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. diff --git a/src/Language/JSON/PrettyPrint.hs b/src/Language/JSON/PrettyPrint.hs index 0f9c8550a..11baece92 100644 --- a/src/Language/JSON/PrettyPrint.hs +++ b/src/Language/JSON/PrettyPrint.hs @@ -11,7 +11,8 @@ import Prologue 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 @@ -20,16 +21,19 @@ 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" @@ -44,8 +48,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,8 +61,10 @@ 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 + => JSONBeautyOpts + -> Stream (Of Fragment) m a + -> Stream (Of Splice) m a +beautifyingJSON _ s = Streaming.for s step where step (Defer el cs) = lift (throwError (NoTranslation el cs)) step (Verbatim txt) = emit txt step (New el cs txt) = case (el, cs) of @@ -71,8 +77,9 @@ beautifyingJSON _ = repeatedly (await >>= step) where -- | Produce whitespace minimal JSON. minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m) - => ProcessT m Fragment Splice -minimizingJSON = repeatedly (await >>= step) where + => Stream (Of Fragment) m a + -> Stream (Of Splice) m a +minimizingJSON s = Streaming.for s step where step (Defer el cs) = lift (throwError (NoTranslation el cs)) step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt diff --git a/src/Language/Python/PrettyPrint.hs b/src/Language/Python/PrettyPrint.hs index 00f0854fe..d1dffecd7 100644 --- a/src/Language/Python/PrettyPrint.hs +++ b/src/Language/Python/PrettyPrint.hs @@ -5,7 +5,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 +15,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 diff --git a/src/Language/Ruby/PrettyPrint.hs b/src/Language/Ruby/PrettyPrint.hs index 6b6abbcce..034910a68 100644 --- a/src/Language/Ruby/PrettyPrint.hs +++ b/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 diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index b28127b89..d1cd9f2da 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -95,7 +95,8 @@ stages of the pipeline follows: -} -{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables, RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes, PartialTypeSignatures, RankNTypes, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Reprinting.Pipeline ( runReprinter , runTokenizing @@ -106,10 +107,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 +122,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) _ () -> Stream (Of Splice) _ ()) + -> 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 +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 + -> (Stream (Of Fragment) _ () -> Stream (Of Splice) _ ()) -> Term a History -> Either TranslationError [Splice] -runTranslating src translating tree +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 diff --git a/src/Reprinting/Tokenize.hs b/src/Reprinting/Tokenize.hs index 5905ff99e..507c31b67 100644 --- a/src/Reprinting/Tokenize.hs +++ b/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 diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index eb5208475..9722da239 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -5,25 +5,28 @@ module Reprinting.Translate , contextualizing ) where -import Control.Monad import Control.Effect import Control.Effect.Error import Control.Effect.State +import Control.Monad import Control.Monad.Trans -import Data.Machine +import Streaming +import Streaming.Prelude (yield) +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 = StateC [Scope] ( ErrorC TranslationError PureC) -contextualizing :: ProcessT Translator Token Fragment -contextualizing = repeatedly $ await >>= \case +contextualizing :: Stream (Of Token) Translator a + -> Stream (Of Fragment) Translator a +contextualizing s = Streaming.for s $ \case Chunk source -> yield . Verbatim . Source.toText $ source Element t -> case t of Run f -> lift get >>= \c -> yield (New t c f) @@ -33,10 +36,9 @@ contextualizing = repeatedly $ await >>= \case Exit c -> exitScope c _ -> pure () -enterScope, exitScope :: Scope -> PlanT k Fragment Translator () - +-- PT TODO: this can be nicer +enterScope, exitScope :: Scope -> Stream (Of Fragment) Translator () 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)) diff --git a/src/Reprinting/Typeset.hs b/src/Reprinting/Typeset.hs index 09ef1554e..038f74ac2 100644 --- a/src/Reprinting/Typeset.hs +++ b/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 diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index ad27cdf08..793427890 100644 --- a/src/Tags/Taggable.hs +++ b/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 diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 3f50c3f0a..fd00a6075 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -11,35 +11,41 @@ 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 Streaming.Prelude (yield) +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) +-- PT TODO: fix me as well contextualizing :: ( Member (State [ContextToken]) sig , Carrier sig m ) => Blob -> [Text] - -> Machine.ProcessT m Token Tag -contextualizing Blob{..} symbolsToSummarize = repeatedly $ await >>= \case + -> Stream (Of Token) m a + -> Stream (Of Tag) m a +contextualizing Blob{..} symbolsToSummarize s = Streaming.for s $ \case Enter x r -> lift (enterScope (x, r)) Exit x r -> lift (exitScope (x, r)) Iden iden span docsLiteralRange -> lift (get @[ContextToken]) >>= \case diff --git a/test/Reprinting/Spec.hs b/test/Reprinting/Spec.hs index e8ceae66e..de7fc6d9e 100644 --- a/test/Reprinting/Spec.hs +++ b/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))