mirror of
https://github.com/github/semantic.git
synced 2024-12-28 09:21:35 +03:00
Merge branch 'quiet-parsing' of https://github.com/github/semantic into quiet-parsing
This commit is contained in:
commit
1dce4b089b
src
Analysis
Data
Parsing
Semantic
test
vendor
@ -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.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,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)
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -34,7 +34,6 @@ import Semantic.Telemetry (LogQueue, StatQueue)
|
||||
import System.Exit (die)
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
|
||||
|
||||
justEvaluating
|
||||
= runM
|
||||
. runPrintingTrace
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
2
vendor/effects
vendored
@ -1 +1 @@
|
||||
Subproject commit 8ded4a64133ce77ddd2fc734f455753e62af0ad3
|
||||
Subproject commit e7858dacce6fbb43e76a49e4dbeff1f1815aa290
|
2
vendor/haskell-tree-sitter
vendored
2
vendor/haskell-tree-sitter
vendored
@ -1 +1 @@
|
||||
Subproject commit 7ee860f415959357ec031df93bc424b0f89dbe48
|
||||
Subproject commit 9c28ccf49be8bbc78635bb0927ae1ae43d2f580b
|
Loading…
Reference in New Issue
Block a user