Merge branch 'quiet-parsing' of https://github.com/github/semantic into quiet-parsing

src/Analysis/Declaration.hs

@@ -1,34 +1,37 @@
-{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Declaration
 ( Declaration(..)
 , HasDeclaration
 , declarationAlgebra
 ) where
 
-import Data.Blob
+import Prologue hiding (first, project)
-import Data.Error (Error(..), showExpectation)
+
-import Data.Language as Language
+import           Control.Arrow hiding (first)
-import Data.Range
+import qualified Data.Text as T
-import Data.Location
+
-import Data.Source as Source
+import           Control.Rewriting hiding (apply)
-import Data.Sum
+import           Data.Blob
+import           Data.Error (Error (..), showExpectation)
+import           Data.Language as Language
+import           Data.Location
+import           Data.Range
+import           Data.Source as Source
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
-import Data.Term
+import           Data.Term
-import qualified Data.Text as T
 import qualified Language.Markdown.Syntax as Markdown
 import qualified Language.Ruby.Syntax as Ruby.Syntax
 import qualified Language.TypeScript.Syntax as TypeScript.Syntax
-import Prologue hiding (project)
 
 -- | A declaration’s identifier and type.
 data Declaration
-  = MethodDeclaration   { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe T.Text }
+  = MethodDeclaration   { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe Text }
-  | ClassDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
+  | ClassDeclaration    { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
-  | ModuleDeclaration   { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
+  | ModuleDeclaration   { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
-  | FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
+  | FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
-  | HeadingDeclaration  { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
+  | HeadingDeclaration  { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
-  | ErrorDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
+  | ErrorDeclaration    { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
   deriving (Eq, Generic, Show)
 
 
@@ -96,37 +99,63 @@ instance CustomHasDeclaration whole Declaration.Function where
     -- Do not summarize anonymous functions
     | isEmpty identifierAnn = Nothing
     -- Named functions
-    | otherwise             = Just $ FunctionDeclaration (getSource blobSource identifierAnn) (getFunctionSource blob (In ann decl)) (locationSpan ann) blobLanguage
+    | otherwise             = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) blobLanguage
     where isEmpty = (== 0) . rangeLength . locationByteRange
+          functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
 
 -- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
 instance CustomHasDeclaration whole Declaration.Method where
   customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _)
     -- Methods without a receiver
-    | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) (locationSpan ann) blobLanguage Nothing
+    | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage Nothing
     -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
     | blobLanguage == Go
-    , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) (locationSpan ann) blobLanguage (Just (getSource blobSource receiverType))
+    , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverType))
     -- Methods with a receiver (class methods) are formatted like `receiver.method_name`
-    | otherwise           = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) (locationSpan ann) blobLanguage (Just (getSource blobSource receiverAnn))
+    | otherwise           = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverAnn))
-    where isEmpty = (== 0) . rangeLength . locationByteRange
+    where
+      isEmpty = (== 0) . rangeLength . locationByteRange
+      methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
 
 -- | Produce a 'ClassDeclaration' for 'Declaration.Class' nodes.
 instance CustomHasDeclaration whole Declaration.Class where
   customToDeclaration blob@Blob{..} ann decl@(Declaration.Class _ (Term (In identifierAnn _), _) _ _)
-    = Just $ ClassDeclaration (getSource blobSource identifierAnn) (getClassSource blob (In ann decl)) (locationSpan ann) blobLanguage
+    = Just $ ClassDeclaration (getSource blobSource identifierAnn) classSource (locationSpan ann) blobLanguage
+      where classSource = getIdentifier (arr Declaration.classBody) blob (In ann decl)
 
 instance CustomHasDeclaration whole Ruby.Syntax.Class where
   customToDeclaration blob@Blob{..} ann decl@(Ruby.Syntax.Class (Term (In identifierAnn _), _) _ _)
-    = Just $ ClassDeclaration (getSource blobSource identifierAnn) (getRubyClassSource blob (In ann decl)) (locationSpan ann) blobLanguage
+    = Just $ ClassDeclaration (getSource blobSource identifierAnn) rubyClassSource (locationSpan ann) blobLanguage
+      where rubyClassSource = getIdentifier (arr Ruby.Syntax.classBody) blob (In ann decl)
 
 instance CustomHasDeclaration whole Ruby.Syntax.Module where
   customToDeclaration blob@Blob{..} ann decl@(Ruby.Syntax.Module (Term (In identifierAnn _), _) _)
-    = Just $ ModuleDeclaration (getSource blobSource identifierAnn) (getRubyModuleSource blob (In ann decl)) (locationSpan ann) blobLanguage
+    = Just $ ModuleDeclaration (getSource blobSource identifierAnn) rubyModuleSource (locationSpan ann) blobLanguage
+      where rubyModuleSource = getIdentifier (arr Ruby.Syntax.moduleStatements >>> first) blob (In ann decl)
 
 instance CustomHasDeclaration whole TypeScript.Syntax.Module where
   customToDeclaration blob@Blob{..} ann decl@(TypeScript.Syntax.Module (Term (In identifierAnn _), _) _)
-    = Just $ ModuleDeclaration (getSource blobSource identifierAnn) (getTypeScriptModuleSource blob (In ann decl)) (locationSpan ann) blobLanguage
+    = Just $ ModuleDeclaration (getSource blobSource identifierAnn) tsModuleSource (locationSpan ann) blobLanguage
+      where tsModuleSource = getIdentifier (arr TypeScript.Syntax.moduleStatements >>> first) blob (In ann decl)
+
+-- When encountering a Declaration-annotated term, we need to extract a Text
+-- for the resulting Declaration's 'declarationIdentifier' field. This text
+-- is constructed by slicing out text from the original blob corresponding
+-- to a location, which is found via the passed-in rule.
+getIdentifier :: Functor m
+           => Rule () (m (Term syntax Location)) (Term syntax Location)
+           -> Blob
+           -> TermF m Location (Term syntax Location, a)
+           -> Text
+getIdentifier finder Blob{..} (In a r)
+  = let declRange = locationByteRange a
+        bodyRange = locationByteRange <$> rewrite (finder >>^ annotation) () (fmap fst r)
+        -- Text-based gyrations to slice the identifier out of the provided blob source
+        sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange
+    in either (const mempty) sliceFrom bodyRange
+
+first :: Rule env [a] a
+first = target >>= maybeM (Prologue.fail "empty list") . listToMaybe
 
 getSource :: Source -> Location -> Text
 getSource blobSource = toText . flip Source.slice blobSource . locationByteRange
@@ -171,48 +200,3 @@ instance HasDeclarationWithStrategy 'Default whole syntax where
 -- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasDeclaration' instance for the type.
 instance CustomHasDeclaration whole syntax => HasDeclarationWithStrategy 'Custom whole syntax where
   toDeclarationWithStrategy _ = customToDeclaration
-
-
-getMethodSource :: Blob -> TermF Declaration.Method Location (Term syntax Location, a) -> T.Text
-getMethodSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          Declaration.Method _ _ _ _ (Term (In a' _), _) -> Just a'
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
-
-getFunctionSource :: Blob -> TermF Declaration.Function Location (Term syntax Location, a) -> T.Text
-getFunctionSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          Declaration.Function _ _ _ (Term (In a' _), _) -> Just a'
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
-
-getClassSource :: Blob -> TermF Declaration.Class Location (Term syntax Location, a) -> T.Text
-getClassSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
-
-getRubyClassSource :: Blob -> TermF Ruby.Syntax.Class Location (Term syntax Location, a) -> T.Text
-getRubyClassSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          Ruby.Syntax.Class _ _ (Term (In a' _), _) -> Just a'
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
-
-getRubyModuleSource :: Blob -> TermF Ruby.Syntax.Module Location (Term syntax Location, a) -> T.Text
-getRubyModuleSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          Ruby.Syntax.Module _ [(Term (In a' _), _)] -> Just a'
-          _ -> Nothing
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
-
-getTypeScriptModuleSource :: Blob -> TermF TypeScript.Syntax.Module Location (Term syntax Location, a) -> T.Text
-getTypeScriptModuleSource Blob{..} (In a r)
-  = let declRange = locationByteRange a
-        bodyRange = locationByteRange <$> case r of
-          TypeScript.Syntax.Module _ [(Term (In a' _), _)] -> Just a'
-          _ -> Nothing
-    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange

src/Data/Term.hs

@@ -6,6 +6,7 @@ module Data.Term
 , termOut
 , injectTerm
 , projectTerm
+, guardTerm
 , TermF(..)
 , termSize
 , hoistTerm
@@ -35,6 +36,11 @@ termOut = termFOut . unTerm
 projectTerm :: forall f syntax ann . (f :< syntax) => Term (Sum syntax) ann -> Maybe (f (Term (Sum syntax) ann))
 projectTerm = Sum.project . termOut
 
+guardTerm :: forall m f syntax ann . (f :< syntax, Alternative m)
+          => Term (Sum syntax) ann
+          -> m (f (Term (Sum syntax) ann))
+guardTerm = Sum.projectGuard . termOut
+
 data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur }
   deriving (Eq, Ord, Foldable, Functor, Show, Traversable)
 

src/Parsing/TreeSitter.hs

@@ -6,10 +6,9 @@ module Parsing.TreeSitter
 
 import Prologue hiding (bracket)
 
-import           Control.Concurrent.Async
 import qualified Control.Exception as Exc (bracket)
 import           Control.Monad.Effect
-import           Control.Monad.Effect.Exception
+import           Control.Monad.Effect.Resource
 import           Control.Monad.Effect.Trace
 import           Control.Monad.IO.Class
 import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
@@ -57,18 +56,26 @@ runParser parser blobSource  = unsafeUseAsCStringLen (sourceBytes blobSource) $
 
 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
 -- Returns Nothing if the operation timed out.
-parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Timeout effects, Member Trace effects, PureEffects effects) => Duration -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
+parseToAST :: ( Bounded grammar
-parseToAST parseTimeout language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
+              , Enum grammar
+              , Member (Lift IO) effects
+              , Member Resource effects
+              , Member Timeout effects
+              , Member Trace effects
+              )
+           => Duration
+           -> Ptr TS.Language
+           -> Blob
+           -> Eff effects (Maybe (AST [] grammar))
+parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
   liftIO $ do
     TS.ts_parser_halt_on_error parser (CBool 1)
     TS.ts_parser_set_language parser language
 
   trace $ "tree-sitter: beginning parsing " <> blobPath
 
-  parsing <- liftIO . async $ runParser parser blobSource
-
   -- Kick the parser off asynchronously and wait according to the provided timeout.
-  res <- timeout parseTimeout $ liftIO (wait parsing)
+  res <- timeout parseTimeout $ liftIO (runParser parser blobSource)
 
   case res of
     Just Failed          -> Nothing  <$ trace ("tree-sitter: parsing failed " <> blobPath)

src/Semantic/Parse.hs

@@ -38,7 +38,7 @@ runParse QuietTermRenderer            = distributeFoldMap $ \blob ->
   where
     showTiming Blob{..} (res, duration) =
       let status = if isLeft res then "ERR" else "OK"
-      in stringUtf8 (status <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
+      in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
 
 -- | For testing and running parse-examples.
 runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder

src/Semantic/REPL.hs

@@ -5,6 +5,7 @@ module Semantic.REPL
 ) where
 
 import Control.Abstract hiding (Continue, List, string)
+import Control.Monad.Effect.Resource
 import Control.Monad.IO.Class
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.Environment as Env
@@ -70,7 +71,7 @@ runREPL prefs settings = interpret $ \case
 
 rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
 
-repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runTimeout (runM . runDistribute) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
+repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do
   blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths)
   package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package)

src/Semantic/Task.hs

@@ -62,6 +62,7 @@ import           Control.Monad
 import           Control.Monad.Effect
 import           Control.Monad.Effect.Exception
 import           Control.Monad.Effect.Reader
+import           Control.Monad.Effect.Resource
 import           Control.Monad.Effect.Trace
 import           Data.Blob
 import           Data.Bool
@@ -99,6 +100,7 @@ type TaskEff = Eff '[ Task
                     , Telemetry
                     , Exc SomeException
                     , Timeout
+                    , Resource
                     , Distribute
                     , Lift IO
                     ]
@@ -152,7 +154,8 @@ runTaskWithConfig options logger statter task = do
         run
           = runM
           . runDistribute
-          . runTimeout (runM . runDistribute)
+          . runResource (runM . runDistribute)
+          . runTimeout (runM . runDistribute . runResource (runM . runDistribute))
           . runError
           . runTelemetry logger statter
           . runTraceInTelemetry
@@ -187,7 +190,7 @@ instance Effect Task where
   handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
-runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
+runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a
 runTaskF = interpret $ \ task -> case task of
   Parse parser blob -> runParser blob parser
   Analyze interpret analysis -> pure (interpret analysis)
@@ -209,7 +212,7 @@ data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut Fil
 instance Exception ParserCancelled
 
 -- | Parse a 'Blob' in 'IO'.
-runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
+runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Resource effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term
 runParser blob@Blob{..} parser = case parser of
   ASTParser language ->
     time "parse.tree_sitter_ast_parse" languageTag $ do
@@ -239,6 +242,7 @@ runParser blob@Blob{..} parser = case parser of
                          , Member Telemetry effs
                          , Member Timeout effs
                          , Member Trace effs
+                         , Member Resource effs
                          , PureEffects effs
                          )
                       => (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location))

src/Semantic/Util.hs

@@ -34,7 +34,6 @@ import           Semantic.Telemetry (LogQueue, StatQueue)
 import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
 
-
 justEvaluating
   = runM
   . runPrintingTrace

src/Semantic/Util/Rewriting.hs

@@ -1,29 +1,27 @@
 {-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
-{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-}
+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists -Wno-incomplete-uni-patterns #-}
 module Semantic.Util.Rewriting where
 
-import Prelude hiding (id, (.), readFile)
+import Prelude hiding (id, readFile, (.))
+import Prologue
 
-import           Control.Abstract
-import           Control.Abstract.Matching
 import           Control.Category
-import           Data.Blob
 import qualified Data.ByteString.Char8 as BC
+import           Text.Show.Pretty (pPrint)
+
+import           Control.Abstract.Matching
+import           Control.Rewriting hiding (fromMatcher, target)
+import           Data.Blob
 import           Data.History
 import qualified Data.Language as Language
-import           Data.Machine
-import           Data.Machine.Runner
 import           Data.Project hiding (readFile)
 import qualified Data.Source as Source
-import qualified Data.Sum as Sum
 import qualified Data.Syntax.Literal as Literal
 import           Data.Term
 import           Language.JSON.PrettyPrint
-import           Language.Ruby.PrettyPrint
 import           Language.Python.PrettyPrint
-import           Matching.Core
+import           Language.Ruby.PrettyPrint
 import           Parsing.Parser
-import           Prologue hiding (weaken)
 import           Reprinting.Pipeline
 import           Semantic.IO as IO
 import           Semantic.Task
@@ -31,7 +29,7 @@ import           Semantic.Task
 testPythonFile = do
   let path = "test/fixtures/python/reprinting/function.py"
   src  <- blobSource <$> readBlobFromPath (File path Language.Python)
-  tree <- parseFile miniPythonParser path
+  tree <- parseFile' miniPythonParser path
   pure (src, tree)
 
 testPythonPipeline = do
@@ -53,7 +51,7 @@ testPythonPipeline''' = do
 testRubyFile = do
   let path = "test/fixtures/ruby/reprinting/infix.rb"
   src  <- blobSource <$> readBlobFromPath (File path Language.Ruby)
-  tree <- parseFile miniRubyParser path
+  tree <- parseFile' miniRubyParser path
   pure (src, tree)
 
 testRubyPipeline = do
@@ -77,80 +75,58 @@ printToTerm = either (putStrLn . show) (BC.putStr . Source.sourceBytes)
 testJSONFile = do
   let path = "test/fixtures/javascript/reprinting/map.json"
   src  <- blobSource <$> readBlobFromPath (File path Language.JSON)
-  tree <- parseFile jsonParser path
+  tree <- parseFile' jsonParser path
   pure (src, tree)
 
-renameKey :: (Literal.TextElement :< fs, Literal.KeyValue :< fs, Apply Functor fs) => Term (Sum fs) History -> Term (Sum fs) History
+renameKey :: ( Literal.TextElement :< fs
-renameKey p = case projectTerm p of
+             , Apply Functor fs
-  Just (Literal.KeyValue k v)
+             , term ~ Term (Sum fs) History
-    | Just (Literal.TextElement x) <- Sum.project (termOut k)
+             )
-    , x == "\"foo\""
+          => Rewrite (env, term) (Literal.KeyValue term)
-    -> let newKey = termIn (termAnnotation k) (inject (Literal.TextElement "\"fooA\""))
+renameKey = do
-       in remark Refactored (termIn (termAnnotation p) (inject (Literal.KeyValue newKey v)))
+  Literal.KeyValue k v <- id
-  _ -> Term (fmap renameKey (unTerm p))
+  guard (projectTerm k == Just (Literal.TextElement "\"foo\""))
+  new <- modified (Literal.TextElement "\"fooA\"")
+  pure (Literal.KeyValue new v)
 
 testRenameKey = do
   (src, tree) <- testJSONFile
-  let tagged = renameKey (mark Unmodified tree)
+  let (Right tagged) = rewrite (somewhere' renameKey) () (mark Unmodified tree)
+  pPrint tagged
   printToTerm $ runReprinter src defaultJSONPipeline tagged
 
-increaseNumbers :: (Literal.Float :< fs, Apply Functor fs) => Term (Sum fs) History -> Term (Sum fs) History
+increaseNumbers :: (term ~ Term (Sum fs) History) => Rewrite (env, term) (Literal.Float term)
-increaseNumbers p = case Sum.project (termOut p) of
+increaseNumbers = do
-  Just (Literal.Float t) -> remark Refactored (termIn (termAnnotation p) (inject (Literal.Float (t <> "0"))))
+  (Literal.Float c) <- id
-  Nothing                -> Term (fmap increaseNumbers (unTerm p))
+  pure (Literal.Float (c <> "0"))
 
-addKVPair :: forall effs syntax term .
+addKVPair :: ( Literal.TextElement :< syn
-  ( Apply Functor syntax
+             , Literal.KeyValue :< syn
-  , Literal.Hash :< syntax
+             , Literal.Array :< syn
-  , Literal.Array :< syntax
+             , Apply Functor syn
-  , Literal.TextElement :< syntax
+             , term ~ Term (Sum syn) History
-  , Literal.KeyValue :< syntax
+             ) => Rewrite (env, term) (Literal.Hash term)
-  , term ~ Term (Sum syntax) History
+addKVPair = do
-  ) =>
+  Literal.Hash els <- id
-  ProcessT (Eff effs) (Either term (term, Literal.Hash term)) term
+  k <- modified $ Literal.TextElement "\"added\""
-addKVPair = repeatedly $ do
+  v <- modified $ Literal.Array []
-  t <- await
+  pair <- modified $ Literal.KeyValue k v
-  Data.Machine.yield (either id injKVPair t)
+  pure (Literal.Hash (pair : els))
-  where
-    injKVPair :: (term, Literal.Hash term) -> term
-    injKVPair (origTerm, Literal.Hash xs) =
-      remark Refactored (injectTerm ann (Literal.Hash (xs <> [newItem])))
-      where
-        newItem = termIn ann (inject (Literal.KeyValue k v))
-        k = termIn ann (inject (Literal.TextElement "\"added\""))
-        v = termIn ann (inject (Literal.Array []))
-        ann = termAnnotation origTerm
 
 testAddKVPair = do
   (src, tree) <- testJSONFile
-  tagged <- runM $ cata (toAlgebra (fromMatcher matchHash ~> addKVPair)) (mark Unmodified tree)
+  let (Right tagged) = rewrite (somewhere addKVPair markRefactored) () (mark Unmodified tree)
   printToTerm $ runReprinter src defaultJSONPipeline tagged
 
-overwriteFloats :: forall effs syntax term .
+overwriteFloats :: Rewrite (env, term) (Literal.Float term)
-  ( Apply Functor syntax
+overwriteFloats = pure (Literal.Float "0")
-  , Literal.Float :< syntax
-  , term ~ Term (Sum syntax) History
-  ) =>
-  ProcessT (Eff effs) (Either term (term, Literal.Float term)) term
-overwriteFloats = repeatedly $ do
-  t <- await
-  Data.Machine.yield (either id injFloat t)
-  where injFloat :: (term, Literal.Float term) -> term
-        injFloat (term, _) = remark Refactored (termIn (termAnnotation term) (inject (Literal.Float "0")))
 
 testOverwriteFloats = do
   (src, tree) <- testJSONFile
-  tagged <- runM $ cata (toAlgebra (fromMatcher matchFloat ~> overwriteFloats)) (mark Unmodified tree)
+  let (Right tagged) = rewrite (somewhere overwriteFloats markRefactored) () (mark Unmodified tree)
+  pPrint tagged
   printToTerm $ runReprinter src defaultJSONPipeline tagged
 
-findKV ::
-  ( Literal.KeyValue :< syntax
-  , Literal.TextElement :< syntax
-  , term ~ Term (Sum syntax) History
-  ) =>
-  Text -> ProcessT (Eff effs) term (Either term (term, Literal.KeyValue term))
-findKV name = fromMatcher (kvMatcher name)
-
 kvMatcher :: forall fs term .
   ( Literal.KeyValue :< fs
   , Literal.TextElement :< fs
@@ -163,41 +139,23 @@ kvMatcher name = matchM projectTerm target <* matchKey where
         match Literal.textElementContent $
           ensure (== name)
 
-changeKV :: forall effs syntax term .
+changeKV :: ( Apply Functor syntax
-  ( Apply Functor syntax
+            , Literal.Array :< syntax
-  , Literal.KeyValue :< syntax
+            , Literal.Float :< syntax
-  , Literal.Array :< syntax
+            , term ~ Term (Sum syntax) History
-  , Literal.Float :< syntax
+            )
-  , term ~ Term (Sum syntax) History
+         => Rewrite (env, term) (Literal.KeyValue term)
-  ) =>
+changeKV = do
-  ProcessT (Eff effs) (Either term (term, Literal.KeyValue term)) term
+  (Literal.KeyValue k v) <- id
-changeKV = auto $ either id injKV
+  (Literal.Array vals) <- guardTerm v
-  where
+  let float = remark Refactored (injectTerm (annotation v) (Literal.Float "4"))
-    injKV :: (term, Literal.KeyValue term) -> term
+  let newArr = remark Refactored (injectTerm (annotation v) (Literal.Array (float:vals)))
-    injKV (term, Literal.KeyValue k v) = case projectTerm v of
+  pure (Literal.KeyValue k newArr)
-      Just (Literal.Array elems) -> remark Refactored (termIn ann (inject (Literal.KeyValue k (newArray elems))))
-      _ -> term
-      where newArray xs = termIn ann (inject (Literal.Array (xs <> [float])))
-            float = termIn ann (inject (Literal.Float "4"))
-            ann = termAnnotation term
 
 testChangeKV = do
   (src, tree) <- testJSONFile
-  tagged <- runM $ cata (toAlgebra (findKV "\"bar\"" ~> changeKV)) (mark Unmodified tree)
+  let (Right tagged) = rewrite (somewhere' changeKV) () (mark Unmodified tree)
   printToTerm $ runReprinter src defaultJSONPipeline tagged
 
--- Temporary, until new KURE system lands.
+parseFile' :: Parser term -> FilePath -> IO term
-fromMatcher :: Matcher from to -> ProcessT (Eff effs) from (Either from (from, to))
+parseFile' parser = runTask . (parse parser <=< readBlob . file)
-fromMatcher m = auto go where go x = maybe (Left x) (\y -> Right (x, y)) (stepMatcher x m)
-
--- Turn a 'ProccessT' into an FAlgebra.
-toAlgebra :: (Traversable (Base t), Corecursive t)
-          => ProcessT (Eff effs) t t
-          -> FAlgebra (Base t) (Eff effs t)
-toAlgebra m t = do
-  inner <- sequenceA t
-  res <- runT1 (source (Just (embed inner)) ~> m)
-  pure (fromMaybe (embed inner) res)
-
-parseFile :: Parser term -> FilePath -> IO term
-parseFile parser = runTask . (parse parser <=< readBlob . file)

test/Examples.hs

@@ -50,6 +50,7 @@ main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
           Left (SomeException e) -> case cast e of
             -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build.
             Just (AssignmentTimedOut _ _) -> pendingWith $ show (displayException e)
+            Just (ParserTimedOut _ _) -> pendingWith $ show (displayException e)
             -- Other exceptions are true failures
             _ -> expectationFailure (show (displayException e))
           _ -> if file `elem` knownFailures

test/Rendering/TOC/Spec.hs

@@ -16,7 +16,7 @@ import Data.Sum
 import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
-import Data.Union
+import Data.Union hiding (forAll)
 import Diffing.Algorithm
 import Diffing.Interpreter
 import Prelude

test/Reprinting/Spec.hs

@@ -8,11 +8,12 @@ import           Data.Foldable
 import           Data.Functor.Foldable (cata, embed)
 import qualified Data.Machine as Machine
 
+import           Control.Rewriting hiding (context)
 import           Data.Algebra
 import           Data.Blob
 import qualified Data.Language as Language
-import           Data.Reprinting.Token
 import           Data.Reprinting.Scope
+import           Data.Reprinting.Token
 import           Data.Sum
 import qualified Data.Syntax.Literal as Literal
 import           Language.JSON.PrettyPrint
@@ -60,7 +61,7 @@ spec = describe "reprinting" $ do
         printed `shouldBe` Right src
 
       it "should be able to parse the output of a refactor" $ do
-        let tagged = increaseNumbers (mark Refactored tree)
+        let (Right tagged) = rewrite (somewhere increaseNumbers markRefactored) () (mark Unmodified tree)
         let (Right printed) = runReprinter src defaultJSONPipeline tagged
         tree' <- runTask (parse jsonParser (Blob printed path Language.JSON))
         length tree' `shouldSatisfy` (/= 0)

vendor/effects

@@ -1 +1 @@
-Subproject commit 8ded4a64133ce77ddd2fc734f455753e62af0ad3
+Subproject commit e7858dacce6fbb43e76a49e4dbeff1f1815aa290

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 7ee860f415959357ec031df93bc424b0f89dbe48
+Subproject commit 9c28ccf49be8bbc78635bb0927ae1ae43d2f580b