github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-19 12:51:52 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Ayman Nadeem 2018-10-17 12:12:23 -04:00
commit 1dce4b089b
13 changed files with 152 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
src/Analysis/Declaration.hs
View File

@ -1,34 +1,37 @@
{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Declaration
( Declaration(..)
, HasDeclaration
, declarationAlgebra
) where
import Prologue hiding (first, project)
import Control.Arrow hiding (first)
import qualified Data.Text as T
import Control.Rewriting hiding (apply)
import Data.Blob
import Data.Error (Error (..), showExpectation)
import Data.Language as Language
import Data.Range
import Data.Location
import Data.Range
import Data.Source as Source
import Data.Sum
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
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 }
| ClassDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
| ModuleDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
| FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
| HeadingDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
| ErrorDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationSpan :: Span, declarationLanguage :: Language }
= MethodDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe Text }
| ClassDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| ModuleDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| HeadingDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
| 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))
where isEmpty = (== 0) . rangeLength . locationByteRange
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverAnn))
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

6
src/Data/Term.hs
View File

@ -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)

21
src/Parsing/TreeSitter.hs
View File

@ -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 parseTimeout language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
parseToAST :: ( Bounded grammar
, 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)

2
src/Semantic/Parse.hs
View File

@ -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

3
src/Semantic/REPL.hs
View File

@ -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)

10
src/Semantic/Task.hs
View File

@ -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))

1
src/Semantic/Util.hs
View File

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

156
src/Semantic/Util/Rewriting.hs
View File

@ -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 p = case projectTerm p of
Just (Literal.KeyValue k v)
| Just (Literal.TextElement x) <- Sum.project (termOut k)
, x == "\"foo\""
-> let newKey = termIn (termAnnotation k) (inject (Literal.TextElement "\"fooA\""))
in remark Refactored (termIn (termAnnotation p) (inject (Literal.KeyValue newKey v)))
_ -> Term (fmap renameKey (unTerm p))
renameKey :: ( Literal.TextElement :< fs
, Apply Functor fs
, term ~ Term (Sum fs) History
)
=> Rewrite (env, term) (Literal.KeyValue term)
renameKey = do
Literal.KeyValue k v <- id
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 p = case Sum.project (termOut p) of
Just (Literal.Float t) -> remark Refactored (termIn (termAnnotation p) (inject (Literal.Float (t <> "0"))))
Nothing -> Term (fmap increaseNumbers (unTerm p))
increaseNumbers :: (term ~ Term (Sum fs) History) => Rewrite (env, term) (Literal.Float term)
increaseNumbers = do
(Literal.Float c) <- id
pure (Literal.Float (c <> "0"))
addKVPair :: forall effs syntax term .
( Apply Functor syntax
, Literal.Hash :< syntax
, Literal.Array :< syntax
, Literal.TextElement :< syntax
, Literal.KeyValue :< syntax
, term ~ Term (Sum syntax) History
) =>
ProcessT (Eff effs) (Either term (term, Literal.Hash term)) term
addKVPair = repeatedly $ do
t <- await
Data.Machine.yield (either id injKVPair t)
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
addKVPair :: ( Literal.TextElement :< syn
, Literal.KeyValue :< syn
, Literal.Array :< syn
, Apply Functor syn
, term ~ Term (Sum syn) History
) => Rewrite (env, term) (Literal.Hash term)
addKVPair = do
Literal.Hash els <- id
k <- modified $ Literal.TextElement "\"added\""
v <- modified $ Literal.Array []
pair <- modified $ Literal.KeyValue k v
pure (Literal.Hash (pair : els))
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 .
( Apply Functor syntax
, 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")))
overwriteFloats :: Rewrite (env, term) (Literal.Float term)
overwriteFloats = pure (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 .
( Apply Functor syntax
, Literal.KeyValue :< syntax
changeKV :: ( Apply Functor syntax
, Literal.Array :< syntax
, Literal.Float :< syntax
, term ~ Term (Sum syntax) History
) =>
ProcessT (Eff effs) (Either term (term, Literal.KeyValue term)) term
changeKV = auto $ either id injKV
where
injKV :: (term, Literal.KeyValue term) -> term
injKV (term, Literal.KeyValue k v) = case projectTerm v of
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
)
=> Rewrite (env, term) (Literal.KeyValue term)
changeKV = do
(Literal.KeyValue k v) <- id
(Literal.Array vals) <- guardTerm v
let float = remark Refactored (injectTerm (annotation v) (Literal.Float "4"))
let newArr = remark Refactored (injectTerm (annotation v) (Literal.Array (float:vals)))
pure (Literal.KeyValue k newArr)
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.
fromMatcher :: Matcher from to -> ProcessT (Eff effs) from (Either from (from, to))
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)
parseFile' :: Parser term -> FilePath -> IO term
parseFile' parser = runTask . (parse parser <=< readBlob . file)

1
test/Examples.hs
View File

@ -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

2
test/Rendering/TOC/Spec.hs
View File

@ -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

5
test/Reprinting/Spec.hs
View File

@ -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)

2
vendor/effects vendored

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

2
vendor/haskell-tree-sitter vendored

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