github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 18:06:14 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #295 from github/parse-effect

Browse Source 
Parse effect
This commit is contained in:
Patrick Thomson 2019-10-01 18:11:29 -04:00 committed by GitHub
commit 4f350ee0c1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
22 changed files with 381 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
semantic.cabal
View File

@ -114,8 +114,12 @@ library
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.Value
-- Carriers
, Control.Carrier.Parse.Measured
, Control.Carrier.Parse.Simple
-- Effects
, Control.Effect.Interpose
, Control.Effect.Parse
, Control.Effect.REPL
, Control.Rewriting
-- Datatypes for abstract interpretation

160
src/Control/Carrier/Parse/Measured.hs Normal file
View File

@ -0,0 +1,160 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
-- | A carrier for 'Parse' effects suitable for use in production.
module Control.Carrier.Parse.Measured
( -- * Parse effect
module Control.Effect.Parse
-- * Parse carrier
, ParseC(..)
-- * Exceptions
, ParserCancelled(..)
) where
import qualified Assigning.Assignment as Assignment
import qualified Assigning.Assignment.Deterministic as Deterministic
import Control.Effect.Error
import Control.Effect.Carrier
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Effect.Trace
import Control.Exception
import Control.Monad.IO.Class
import Data.Blob
import qualified Data.Error as Error
import qualified Data.Flag as Flag
import qualified Data.Syntax as Syntax
import Data.Sum
import Data.Term
import Data.Typeable
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (project)
import Semantic.Config
import Semantic.Task (TaskSession(..))
import Semantic.Telemetry
import Semantic.Timeout
import Source.Source (Source)
newtype ParseC m a = ParseC { runParse :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance ( Carrier sig m
, Member (Error SomeException) sig
, Member (Reader TaskSession) sig
, Member Telemetry sig
, Member Timeout sig
, Member Trace sig
, MonadIO m
)
=> Carrier (Parse :+: sig) (ParseC m) where
eff (L (Parse parser blob k)) = runParser blob parser >>= k
eff (R other) = ParseC (eff (handleCoercible other))
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Error SomeException) sig, Member (Reader TaskSession) sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m)
=> Blob
-> Parser term
-> m term
runParser blob@Blob{..} parser = case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- asks config
parseToAST (configTreeSitterParseTimeout config) language blob
>>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
UnmarshalParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- asks config
parseToPreciseAST (configTreeSitterParseTimeout config) language blob
>>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure
AssignmentParser parser assignment -> runAssignment Assignment.assign parser blob assignment
DeterministicParser parser assignment -> runAssignment Deterministic.assign parser blob assignment
MarkdownParser ->
time "parse.cmark_parse" languageTag $
let term = cmarkParser blobSource
in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser blob parser
where languageTag = [("language" :: String, show (blobLanguage blob))]
data ParserCancelled = ParserTimedOut | AssignmentTimedOut
deriving (Show, Typeable)
instance Exception ParserCancelled
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String]
errors = cata $ \ (In Assignment.Loc{..} syntax) ->
maybe (fold syntax) (pure . Syntax.unError span) (project syntax)
runAssignment
:: ( Apply Foldable syntaxes
, Apply Functor syntaxes
, Element Syntax.Error syntaxes
, Member (Error SomeException) sig
, Member (Reader TaskSession) sig
, Member Telemetry sig
, Member Timeout sig
, Member Trace sig
, Carrier sig m
, MonadIO m
)
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Loc) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Loc))
-> Parser ast
-> Blob
-> assignment (Term (Sum syntaxes) Assignment.Loc)
-> m (Term (Sum syntaxes) Assignment.Loc)
runAssignment assign parser blob@Blob{..} assignment = do
taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession)
let isPublic' = ("github_is_public", show (isPublic taskSession))
let logPrintFlag = configLogPrintSource . config $ taskSession
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath blob else "<filtered>")
let logFields = requestID' : isPublic' : blobFields : languageTag
let shouldFailForTesting = configFailParsingForTesting $ config taskSession
let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession
let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : logFields)
throwError (toException err)
res <- timeout (configAssignmentTimeout (config taskSession)) . time "parse.assign" languageTag $
case assign blobSource assignment ast of
Left err -> do
writeStat (increment "parse.assign_errors" languageTag)
logError taskSession Error blob err (("task", "assign") : logFields)
throwError (toException err)
Right term -> do
for_ (zip (errors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of
Just "ParseError" -> do
when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag)
logError taskSession Warning blob err (("task", "parse") : logFields)
when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err))
_ -> do
when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag)
logError taskSession Warning blob err (("task", "assign") : logFields)
when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err))
term <$ writeStat (count "parse.nodes" (length term) languageTag)
case res of
Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r
_ -> do
writeStat (increment "assign.assign_timeouts" languageTag)
writeLog Error "assignment timeout" (("task", "assign") : logFields)
throwError (SomeException AssignmentTimedOut)
where languageTag = [("language", show (blobLanguage blob))]
-- | Log an 'Error.Error' at the specified 'Level'.
logError :: (Member Telemetry sig, Carrier sig m)
=> TaskSession
-> Level
-> Blob
-> Error.Error String
-> [(String, String)]
-> m ()
logError TaskSession{..} level blob err =
let shouldLogSource = configLogPrintSource config
shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config
in writeLog level (Error.formatError shouldLogSource shouldColorize blob err)

73
src/Control/Carrier/Parse/Simple.hs Normal file
View File

@ -0,0 +1,73 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
-- | A carrier for 'Parse' effects suitable for use in the repl, tests, etc.
module Control.Carrier.Parse.Simple
( -- * Parse effect
module Control.Effect.Parse
-- * Parse carrier
, ParseC(..)
, runParse
-- * Exceptions
, ParseFailure(..)
) where
import qualified Assigning.Assignment as Assignment
import qualified Assigning.Assignment.Deterministic as Deterministic
import Control.Effect.Error
import Control.Effect.Carrier
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Monad.IO.Class
import Data.Blob
import Data.Typeable
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
runParse :: Duration -> ParseC m a -> m a
runParse timeout = runReader timeout . runParseC
newtype ParseC m a = ParseC { runParseC :: ReaderC Duration m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance ( Carrier sig m
, Member (Error SomeException) sig
, MonadIO m
)
=> Carrier (Parse :+: sig) (ParseC m) where
eff (L (Parse parser blob k)) = ParseC ask >>= \ timeout -> runParser timeout blob parser >>= k
eff (R other) = ParseC (send (handleCoercible other))
-- | Parse a 'Blob' in 'IO'.
runParser
:: ( Carrier sig m
, Member (Error SomeException) sig
, MonadIO m
)
=> Duration
-> Blob
-> Parser term
-> m term
runParser timeout blob@Blob{..} parser = case parser of
ASTParser language ->
parseToAST timeout language blob
>>= either (throwError . SomeException . ParseFailure) pure
UnmarshalParser language ->
parseToPreciseAST timeout language blob
>>= either (throwError . SomeException . ParseFailure) pure
AssignmentParser parser assignment ->
runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign blobSource assignment
DeterministicParser parser assignment ->
runParser timeout blob parser >>= either (throwError . toException) pure . Deterministic.assign blobSource assignment
MarkdownParser ->
let term = cmarkParser blobSource
in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser timeout blob parser
data ParseFailure = ParseFailure String
deriving (Show, Typeable)
instance Exception ParseFailure

29
src/Control/Effect/Parse.hs Normal file
View File

@ -0,0 +1,29 @@
{-# LANGUAGE ExistentialQuantification #-}
module Control.Effect.Parse
( -- * Parse effect
Parse(..)
, parse
) where
import Control.Effect.Carrier
import Data.Blob
import Parsing.Parser
data Parse m k
= forall term . Parse (Parser term) Blob (term -> m k)
deriving instance Functor m => Functor (Parse m)
instance HFunctor Parse where
hmap f (Parse parser blob k) = Parse parser blob (f . k)
instance Effect Parse where
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
-- | Parse a 'Blob' with the given 'Parser'.
parse :: (Member Parse sig, Carrier sig m)
=> Parser term
-> Blob
-> m term
parse parser blob = send (Parse parser blob pure)

25
src/Parsing/TreeSitter.hs
View File

@ -10,7 +10,6 @@ import Prologue
import Control.Effect.Fail
import Control.Effect.Lift
import Control.Effect.Reader
import Control.Effect.Trace
import Foreign
import Foreign.C.Types (CBool (..))
import Foreign.Marshal.Array (allocaArray)
@ -33,43 +32,36 @@ import qualified TreeSitter.Unmarshal as TS
-- | Parse a 'Blob' with the given 'TS.Language' and return its AST.
-- Returns 'Nothing' if the operation timed out.
parseToAST :: ( Bounded grammar
, Carrier sig m
, Enum grammar
, Member Trace sig
, MonadIO m
)
=> Duration
-> Ptr TS.Language
-> Blob
-> m (Maybe (AST [] grammar))
-> m (Either String (AST [] grammar))
parseToAST parseTimeout language blob = runParse parseTimeout language blob (fmap Right . anaM toAST <=< peek)
parseToPreciseAST
:: ( Carrier sig m
, Member Trace sig
, MonadIO m
:: ( MonadIO m
, TS.Unmarshal t
)
=> Duration
-> Ptr TS.Language
-> Blob
-> m (Maybe (t Loc))
-> m (Either String (t Loc))
parseToPreciseAST parseTimeout language blob = runParse parseTimeout language blob $ \ rootPtr ->
TS.withCursor (castPtr rootPtr) $ \ cursor ->
runM (runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode))))
runParse
:: ( Carrier sig m
, Member Trace sig
, MonadIO m
)
:: MonadIO m
=> Duration
-> Ptr TS.Language
-> Blob
-> (Ptr TS.Node -> IO (Either String a))
-> m (Maybe a)
runParse parseTimeout language b@Blob{..} action = do
result <- liftIO . TS.withParser language $ \ parser -> do
-> m (Either String a)
runParse parseTimeout language Blob{..} action =
liftIO . TS.withParser language $ \ parser -> do
let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
TS.ts_parser_set_timeout_micros parser timeoutMicros
TS.ts_parser_halt_on_error parser (CBool 1)
@ -82,9 +74,6 @@ runParse parseTimeout language b@Blob{..} action = do
TS.withRootNode treePtr action
else
pure (Left "tree-sitter: incompatible versions")
case result of
Left err -> Nothing <$ trace err <* trace ("tree-sitter: parsing failed " <> blobPath b)
Right ast -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath b)
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
toAST node@TS.Node{..} = do

9
src/Semantic/AST.hs
View File

@ -13,10 +13,13 @@ import Data.ByteString.Builder
import Data.List (intersperse)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Data.AST
import Data.Blob
import Parsing.Parser
import Rendering.JSON (renderJSONAST)
import Semantic.Config
import Semantic.Task
import qualified Serializing.Format as F
@ -26,7 +29,7 @@ data SomeAST where
withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
withSomeAST f (SomeAST ast) = f ast
astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m SomeAST
astParseBlob :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Blob -> m SomeAST
astParseBlob blob@Blob{..}
| Just (SomeASTParser parser) <- someASTParser (blobLanguage blob) = SomeAST <$> parse parser blob
| otherwise = noLanguageForBlob (blobPath blob)
@ -35,10 +38,10 @@ astParseBlob blob@Blob{..}
data ASTFormat = SExpression | JSON | Show | Quiet
deriving (Show)
runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => ASTFormat -> [Blob] -> m F.Builder
runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => ASTFormat -> [Blob] -> m F.Builder
runASTParse SExpression = distributeFoldMap (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))
runASTParse Show = distributeFoldMap (astParseBlob >=> withSomeAST (serialize F.Show . fmap nodeSymbol))
runASTParse JSON = distributeFoldMap (\ blob -> astParseBlob blob >>= withSomeAST (render (renderJSONAST blob))) >=> serialize F.JSON
runASTParse JSON = distributeFoldMap (\ blob -> withSomeAST (renderJSONAST blob) <$> astParseBlob blob) >=> serialize F.JSON
runASTParse Quiet = distributeFoldMap $ \blob -> do
result <- time' ((Right <$> astParseBlob blob) `catchError` (pure . Left @SomeException))
pure . mconcat . intersperse "\t" $ [ either (const "ERR") (const "OK") (fst result)

50
src/Semantic/Api/Diffs.hs
View File

@ -14,6 +14,8 @@ module Semantic.Api.Diffs
import Analysis.ConstructorName (ConstructorName)
import Analysis.TOCSummary (HasDeclaration)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens
import Control.Monad.IO.Class
@ -27,12 +29,14 @@ import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Diffing.Algorithm (Diffable)
import Diffing.Interpreter (diffTermPair)
import Parsing.Parser
import Prologue
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
import Semantic.Task as Task
import Semantic.Telemetry as Stat
@ -58,7 +62,7 @@ parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff
type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff f blobPair = doDiff blobPair (const pure) f `catchError` jsonError blobPair
jsonDiff f blobPair = doDiff blobPair (const id) f `catchError` jsonError blobPair
jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
@ -70,7 +74,7 @@ diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraph
diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
where
go :: (DiffEffects sig m) => BlobPair -> m DiffTreeFileGraph
go blobPair = doDiff blobPair (const pure) render
go blobPair = doDiff blobPair (const id) render
`catchError` \(SomeException e) ->
pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
where
@ -85,19 +89,19 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor
sexpDiff :: (DiffEffects sig m) => BlobPair -> m Builder
sexpDiff blobPair = doDiff blobPair (const pure) (const (serialize (SExpression ByConstructorName)))
sexpDiff blobPair = doDiff blobPair (const id) (const (serialize (SExpression ByConstructorName)))
showDiff :: (DiffEffects sig m) => BlobPair -> m Builder
showDiff blobPair = doDiff blobPair (const pure) (const (serialize Show))
showDiff blobPair = doDiff blobPair (const id) (const (serialize Show))
dotGraphDiff :: (DiffEffects sig m) => BlobPair -> m Builder
dotGraphDiff blobPair = doDiff blobPair (const pure) render
dotGraphDiff blobPair = doDiff blobPair (const id) render
where render _ = serialize (DOT (diffStyle "diffs")) . renderTreeGraph
type DiffEffects sig m = (Member (Error SomeException) sig, Member Telemetry sig, Member Distribute sig, Member Task sig, Carrier sig m, MonadIO m)
type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m)
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
type Decorate m a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> m (Term syntax b)
type Decorate a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> Term syntax b
type TermPairConstraints =
'[ ConstructorName
@ -111,33 +115,33 @@ type TermPairConstraints =
]
doDiff :: (DiffEffects sig m)
=> BlobPair -> Decorate m Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
=> BlobPair -> Decorate Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
doDiff blobPair decorate render = do
SomeTermPair terms <- doParse blobPair decorate
diff <- diffTerms blobPair terms
render blobPair diff
diffTerms :: (CanDiff syntax, Member Task sig, Member Telemetry sig, Carrier sig m, MonadIO m)
diffTerms :: (CanDiff syntax, Member Telemetry sig, Carrier sig m, MonadIO m)
=> BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
diffTerms blobs terms = time "diff" languageTag $ do
diff <- diff (runJoin terms)
let diff = diffTermPair (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs
doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m)
=> BlobPair -> Decorate m Loc ann -> m (SomeTermPair TermPairConstraints ann)
doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Carrier sig m)
=> BlobPair -> Decorate Loc ann -> m (SomeTermPair TermPairConstraints ann)
doParse blobPair decorate = case languageForBlobPair blobPair of
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob)
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse haskellParser blob >>= decorate blob)
JavaScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse tsxParser blob >>= decorate blob)
JSON -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse jsonParser blob >>= decorate blob)
JSX -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse tsxParser blob >>= decorate blob)
Markdown -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse markdownParser blob >>= decorate blob)
Python -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse pythonParser blob >>= decorate blob)
Ruby -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse rubyParser blob >>= decorate blob)
TypeScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse typescriptParser blob >>= decorate blob)
TSX -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse tsxParser blob >>= decorate blob)
PHP -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse phpParser blob >>= decorate blob)
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse goParser blob)
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse haskellParser blob)
JavaScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
JSON -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse jsonParser blob)
JSX -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
Markdown -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse markdownParser blob)
Python -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse pythonParser blob)
Ruby -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse rubyParser blob)
TypeScript -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse typescriptParser blob)
TSX -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse tsxParser blob)
PHP -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse phpParser blob)
_ -> noLanguageForBlob (pathForBlobPair blobPair)
data SomeTermPair typeclasses ann where

1
src/Semantic/Api/Symbols.hs
View File

@ -6,6 +6,7 @@ module Semantic.Api.Symbols
) where
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens

5
src/Semantic/Api/TOCSummaries.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-}
module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
import Analysis.Decorator (decoratorWithAlgebra)
import Analysis.TOCSummary (Declaration, declarationAlgebra)
import Control.Effect.Error
import Control.Lens
@ -26,7 +27,7 @@ legacyDiffSummary :: (DiffEffects sig m) => [BlobPair] -> m Summaries
legacyDiffSummary = distributeFoldMap go
where
go :: (DiffEffects sig m) => BlobPair -> m Summaries
go blobPair = doDiff blobPair (decorate . declarationAlgebra) render
go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
`catchError` \(SomeException e) ->
pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)])
where path = T.pack $ pathKeyForBlobPair blobPair
@ -39,7 +40,7 @@ diffSummary :: (DiffEffects sig m) => [BlobPair] -> m DiffTreeTOCResponse
diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
where
go :: (DiffEffects sig m) => BlobPair -> m TOCSummaryFile
go blobPair = doDiff blobPair (decorate . declarationAlgebra) render
go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
`catchError` \(SomeException e) ->
pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
where path = T.pack $ pathKeyForBlobPair blobPair

4
src/Semantic/Api/Terms.hs
View File

@ -16,6 +16,7 @@ module Semantic.Api.Terms
import Analysis.ConstructorName (ConstructorName)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Lens
import Control.Monad
@ -37,6 +38,7 @@ import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task
import Serializing.Format hiding (JSON)
@ -102,7 +104,7 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
in stringUtf8 (status <> "\t" <> show (blobLanguage blob) <> "\t" <> blobPath blob <> "\t" <> show duration <> " ms\n")
type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Task sig, Carrier sig m)
type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m)
type TermConstraints =
'[ Taggable

15
src/Semantic/CLI.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE ApplicativeDo #-}
module Semantic.CLI (main) where
import qualified Control.Carrier.Parse.Measured as Parse
import Control.Effect.Reader
import Control.Exception as Exc (displayException)
import Data.Blob
@ -57,13 +58,13 @@ main = do
(options, task) <- customExecParser (prefs showHelpOnEmpty) arguments
config <- defaultConfig options
res <- withTelemetry config $ \ (TelemetryQueues logger statter _) ->
Task.runTask (Task.TaskSession config "-" (optionsLogPathsOnError options) logger statter) task
Task.runTask (Task.TaskSession config "-" (optionsLogPathsOnError options) logger statter) (Parse.runParse task)
either (die . displayException) pure res
-- | A parser for the application's command-line arguments.
--
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
arguments :: ParserInfo (Options, Task.TaskEff ())
arguments :: ParserInfo (Options, Parse.ParseC Task.TaskC ())
arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description
where
version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
@ -79,13 +80,13 @@ optionsParser = do
logPathsOnError <- switch (long "log-paths" <> help "Log source paths on parse and assignment error.")
pure $ Options logLevel logPathsOnError (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError)
argumentsParser :: Parser (Task.TaskEff ())
argumentsParser :: Parser (Parse.ParseC Task.TaskC ())
argumentsParser = do
subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand)
output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout)
pure $ subparser >>= Task.write output
diffCommand :: Mod CommandFields (Task.TaskEff Builder)
diffCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
where
diffArgumentsParser = do
@ -98,7 +99,7 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change
filesOrStdin <- Right <$> some (Both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
pure $ Task.readBlobPairs filesOrStdin >>= renderer
parseCommand :: Mod CommandFields (Task.TaskEff Builder)
parseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
where
parseArgumentsParser = do
@ -146,7 +147,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer
tsParseCommand :: Mod CommandFields (Task.TaskEff Builder)
tsParseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Generate raw tree-sitter parse trees for path(s)"))
where
tsParseArgumentsParser = do
@ -165,7 +166,7 @@ tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Gene
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
graphCommand :: Mod CommandFields (Task.TaskEff Builder)
graphCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module"))
where
graphArgumentsParser = makeGraphTask

11
src/Semantic/Graph.hs
View File

@ -35,6 +35,7 @@ import Analysis.Abstract.Graph as Graph
import Control.Abstract hiding (String)
import Control.Abstract.PythonPackage as PythonPackage
import Control.Effect.Carrier
import Control.Effect.Parse
import Data.Abstract.Address.Hole as Hole
import Data.Abstract.Address.Monovariant as Monovariant
import Data.Abstract.Address.Precise as Precise
@ -74,8 +75,8 @@ type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Acces
runGraph :: ( Member Distribute sig
, Member (Error SomeException) sig
, Member Parse sig
, Member Resolution sig
, Member Task sig
, Member Trace sig
, Carrier sig m
, Effect sig
@ -230,7 +231,7 @@ runScopeGraph :: Ord address
runScopeGraph = raiseHandler (runState lowerBound)
-- | Parse a list of files into a 'Package'.
parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m)
parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Parse sig, Member Trace sig, Carrier sig m)
=> Parser term -- ^ A parser.
-> Project -- ^ Project to parse into a package.
-> m (Package (Blob, term))
@ -244,7 +245,7 @@ parsePackage parser project = do
n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`.
-- | Parse all files in a project into 'Module's.
parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Parser term -> Project -> m [Module (Blob, term)]
parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Parser term -> Project -> m [Module (Blob, term)]
parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser)
@ -258,9 +259,9 @@ parsePythonPackage :: forall syntax sig m term.
, term ~ Term syntax Loc
, Member (Error SomeException) sig
, Member Distribute sig
, Member Parse sig
, Member Resolution sig
, Member Trace sig
, Member Task sig
, Carrier sig m
, Effect sig
)
@ -320,7 +321,7 @@ parsePythonPackage parser project = do
resMap <- Task.resolutionMap p
pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`.
parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m)
parseModule :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m)
=> Project
-> Parser term
-> File

38
src/Semantic/REPL.hs
View File

@ -7,11 +7,10 @@ module Semantic.REPL
import Control.Abstract hiding (Continue, List, string)
import Control.Abstract.ScopeGraph (runScopeError)
import Control.Abstract.Heap (runHeapError)
import Control.Effect.Carrier
import Control.Carrier.Parse.Simple
import Control.Effect.Catch
import Control.Effect.Lift
import Control.Effect.REPL
import Control.Effect.Resource
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.Evaluatable hiding (string)
import Data.Abstract.Module
@ -28,21 +27,16 @@ import Data.List (uncons)
import Data.Project
import Data.Quieterm
import qualified Data.Text as T
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.LocalTime as LocalTime
import Numeric (readDec)
import Parsing.Parser (rubyParser)
import Prologue
import Semantic.Analysis
import Semantic.Config (logOptionsFromConfig)
import Semantic.Config (configTreeSitterParseTimeout)
import Semantic.Distribute
import Semantic.Graph
import Semantic.Resolution
import Semantic.Task hiding (Error)
import qualified Semantic.Task.Files as Files
import Semantic.Telemetry
import Semantic.Timeout
import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage)
import Semantic.Util
import Source.Span
import System.Console.Haskeline
@ -57,19 +51,15 @@ instance Exception Quit
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
repl proxy parser paths =
withOptions debugOptions $ \config logger statter ->
withOptions debugOptions $ \config _ _ ->
runM
. withDistribute
. runCatch
. runResource
. withTimeout
. runError @SomeException
. runTelemetryIgnoringStat (logOptionsFromConfig config)
. runTraceInTelemetry
. runReader (TaskSession config "-" False logger statter)
. runTraceByPrinting
. Files.runFiles
. runResolution
. runTaskF $ do
. runParse (configTreeSitterParseTimeout config) $ do
blobs <- catMaybes <$> traverse readBlobFromFile (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)
@ -113,24 +103,6 @@ repl proxy parser paths =
-- TODO: drive the flow from within the REPL instead of from without
runTelemetryIgnoringStat :: LogOptions -> TelemetryIgnoringStatC m a -> m a
runTelemetryIgnoringStat logOptions = runReader logOptions . runTelemetryIgnoringStatC
newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: ReaderC LogOptions m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
eff (R other) = TelemetryIgnoringStatC . eff . R . handleCoercible $ other
eff (L op) = do
logOptions <- TelemetryIgnoringStatC ask
case op of
WriteStat _ k -> k
WriteLog level message pairs k -> do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
k
step :: ( Member (Error SomeException) sig
, Member REPL sig
, Member (Reader ModuleInfo) sig

232
src/Semantic/Task.hs
View File

@ -1,10 +1,8 @@
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( Task
, TaskEff
( TaskC
, Level(..)
, RAlgebra
-- * I/O
, Files.readBlob
, Files.readBlobs
@ -22,10 +20,6 @@ module Semantic.Task
, time
, time'
-- * High-level flow
, parse
, decorate
, diff
, render
, serialize
-- * Concurrency
, distribute
@ -43,9 +37,6 @@ module Semantic.Task
, withOptions
, TaskSession(..)
, runTraceInTelemetry
, runTaskF
-- * Exceptions
, ParserCancelled(..)
-- * Re-exports
, Distribute
, Error
@ -55,9 +46,6 @@ module Semantic.Task
, Telemetry
) where
import Analysis.Decorator (decoratorWithAlgebra)
import qualified Assigning.Assignment as Assignment
import qualified Assigning.Assignment.Deterministic as Deterministic
import Control.Effect.Carrier
import Control.Effect.Catch
import Control.Effect.Error
@ -65,21 +53,9 @@ import Control.Effect.Lift
import Control.Effect.Reader
import Control.Effect.Resource
import Control.Effect.Trace
import Control.Monad
import Control.Monad.IO.Class
import Data.Blob
import Data.ByteString.Builder
import Data.Diff
import qualified Data.Error as Error
import qualified Data.Flag as Flag
import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
import Diffing.Algorithm (Diffable)
import Diffing.Interpreter
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (project)
import Semantic.Config
import Semantic.Distribute
@ -88,14 +64,12 @@ import qualified Semantic.Task.Files as Files
import Semantic.Telemetry
import Semantic.Timeout
import Serializing.Format hiding (Options)
import Source.Loc
import Source.Source (Source)
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff
= TaskC
( ResolutionC
type TaskC
= ResolutionC
( Files.FilesC
( ReaderC Config
( ReaderC TaskSession
( TraceInTelemetryC
( TelemetryC
@ -106,41 +80,13 @@ type TaskEff
( DistributeC
( LiftC IO)))))))))))
-- | A function to render terms or diffs.
type Renderer i o = i -> o
-- | A task which parses a 'Blob' with the given 'Parser'.
parse :: (Member Task sig, Carrier sig m)
=> Parser term
-> Blob
-> m term
parse parser blob = send (Parse parser blob pure)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: (Functor f, Member Task sig, Carrier sig m)
=> RAlgebra (TermF f Loc) (Term f Loc) field
-> Term f Loc
-> m (Term f field)
decorate algebra term = send (Decorate algebra term pure)
-- | A task which diffs a pair of terms using the supplied 'Differ' function.
diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m)
=> These (Term syntax ann) (Term syntax ann)
-> m (Diff syntax ann ann)
diff terms = send (Semantic.Task.Diff terms pure)
-- | A task which renders some input using the supplied 'Renderer' function.
render :: (Member Task sig, Carrier sig m)
=> Renderer input output
-> input
-> m output
render renderer input = send (Render renderer input pure)
serialize :: (Member Task sig, Carrier sig m)
serialize :: (Member (Reader Config) sig, Carrier sig m)
=> Format input
-> input
-> m Builder
serialize format input = send (Serialize format input pure)
serialize format input = do
formatStyle <- asks (Flag.choose IsTerminal Plain Colourful . configIsTerminal)
pure (runSerialize formatStyle format input)
data TaskSession
= TaskSession
@ -151,11 +97,11 @@ data TaskSession
, statter :: StatQueue
}
-- | Execute a 'TaskEff' yielding its result value in 'IO'.
runTask :: TaskSession -> TaskEff a -> IO (Either SomeException a)
-- | Execute a 'TaskC' yielding its result value in 'IO'.
runTask :: TaskSession -> TaskC a -> IO (Either SomeException a)
runTask taskSession@TaskSession{..} task = do
(result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a)
let run :: TaskC a -> IO (Either SomeException a)
run
= runM
. withDistribute
@ -166,15 +112,15 @@ runTask taskSession@TaskSession{..} task = do
. runTelemetry logger statter
. runTraceInTelemetry
. runReader taskSession
. runReader config
. Files.runFiles
. runResolution
. runTaskF
run task
queueStat statter stat
pure result
-- | Execute a 'TaskEff' yielding its result value in 'IO' using all default options and configuration.
runTaskWithOptions :: Options -> TaskEff a -> IO (Either SomeException a)
-- | Execute a 'TaskC' yielding its result value in 'IO' using all default options and configuration.
runTaskWithOptions :: Options -> TaskC a -> IO (Either SomeException a)
runTaskWithOptions options task = withOptions options $ \ config logger statter ->
runTask (TaskSession config "-" False logger statter) task
@ -194,153 +140,3 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a
instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
eff (L (Trace str k)) = writeLog Debug str [] >> k
-- | An effect describing high-level tasks to be performed.
data Task (m :: * -> *) k
= forall term . Parse (Parser term) Blob (term -> m k)
| forall f field . Functor f => Decorate (RAlgebra (TermF f Loc) (Term f Loc) field) (Term f Loc) (Term f field -> m k)
| forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k)
| forall input output . Render (Renderer input output) input (output -> m k)
| forall input . Serialize (Format input) input (Builder -> m k)
deriving instance Functor m => Functor (Task m)
instance HFunctor Task where
hmap f (Parse parser blob k) = Parse parser blob (f . k)
hmap f (Decorate decorator term k) = Decorate decorator term (f . k)
hmap f (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (f . k)
hmap f (Render renderer input k) = Render renderer input (f . k)
hmap f (Serialize format input k) = Serialize format input (f . k)
instance Effect Task where
handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k)
handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k)
handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k)
handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k)
handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: TaskC m a -> m a
runTaskF = runTaskC
newtype TaskC m a = TaskC { runTaskC :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
eff (R other) = TaskC . eff . handleCoercible $ other
eff (L op) = case op of
Parse parser blob k -> runParser blob parser >>= k
Decorate algebra term k -> k (decoratorWithAlgebra algebra term)
Semantic.Task.Diff terms k -> k (diffTermPair terms)
Render renderer input k -> k (renderer input)
Serialize format input k -> do
formatStyle <- asks (Flag.choose IsTerminal Plain Colourful . configIsTerminal . config)
k (runSerialize formatStyle format input)
-- | Log an 'Error.Error' at the specified 'Level'.
logError :: (Member Telemetry sig, Carrier sig m)
=> TaskSession
-> Level
-> Blob
-> Error.Error String
-> [(String, String)]
-> m ()
logError TaskSession{..} level blob err =
let shouldLogSource = configLogPrintSource config
shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config
in writeLog level (Error.formatError shouldLogSource shouldColorize blob err)
data ParserCancelled = ParserTimedOut | AssignmentTimedOut
deriving (Show, Typeable)
instance Exception ParserCancelled
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m)
=> Blob
-> Parser term
-> m term
runParser blob@Blob{..} parser = case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- asks config
parseToAST (configTreeSitterParseTimeout config) language blob
>>= maybeM (throwError (SomeException ParserTimedOut))
UnmarshalParser language ->
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- asks config
parseToPreciseAST (configTreeSitterParseTimeout config) language blob
>>= maybeM (throwError (SomeException ParserTimedOut))
AssignmentParser parser assignment -> runAssignment Assignment.assign parser assignment
DeterministicParser parser assignment -> runAssignment Deterministic.assign parser assignment
MarkdownParser ->
time "parse.cmark_parse" languageTag $
let term = cmarkParser blobSource
in length term `seq` pure term
SomeParser parser -> SomeTerm <$> runParser blob parser
where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage blob
errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Loc -> [Error.Error String]
errors = cata $ \ (In Assignment.Loc{..} syntax) -> case syntax of
_ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError span err]
_ -> fold syntax
runAssignment :: ( Apply Foldable syntaxes
, Apply Functor syntaxes
, Element Syntax.Error syntaxes
, Member (Error SomeException) sig
, Member (Lift IO) sig
, Member (Reader TaskSession) sig
, Member Resource sig
, Member Telemetry sig
, Member Timeout sig
, Member Trace sig
, Carrier sig m
, MonadIO m
)
=> (Source -> assignment (Term (Sum syntaxes) Assignment.Loc) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Loc))
-> Parser ast
-> assignment (Term (Sum syntaxes) Assignment.Loc)
-> m (Term (Sum syntaxes) Assignment.Loc)
runAssignment assign parser assignment = do
taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession)
let isPublic' = ("github_is_public", show (isPublic taskSession))
let logPrintFlag = configLogPrintSource . config $ taskSession
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath blob else "<filtered>")
let logFields = requestID' : isPublic' : blobFields : languageTag
let shouldFailForTesting = configFailParsingForTesting $ config taskSession
let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession
let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : logFields)
throwError (toException err)
res <- timeout (configAssignmentTimeout (config taskSession)) . time "parse.assign" languageTag $
case assign blobSource assignment ast of
Left err -> do
writeStat (increment "parse.assign_errors" languageTag)
logError taskSession Error blob err (("task", "assign") : logFields)
throwError (toException err)
Right term -> do
for_ (zip (errors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of
Just "ParseError" -> do
when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag)
logError taskSession Warning blob err (("task", "parse") : logFields)
when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err))
_ -> do
when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag)
logError taskSession Warning blob err (("task", "assign") : logFields)
when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err))
term <$ writeStat (count "parse.nodes" (length term) languageTag)
case res of
Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r
_ -> do
writeStat (increment "assign.assign_timeouts" languageTag)
writeLog Error "assignment timeout" (("task", "assign") : logFields)
throwError (SomeException AssignmentTimedOut)

9
src/Semantic/Util.hs
View File

@ -20,6 +20,7 @@ import Prelude hiding (readFile)
import Control.Abstract
import Control.Abstract.Heap (runHeapError)
import Control.Abstract.ScopeGraph (runScopeError)
import Control.Carrier.Parse.Simple
import Control.Effect.Lift
import Control.Effect.Trace (runTraceByPrinting)
import Control.Exception (displayException)
@ -102,7 +103,7 @@ evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger
-- Evaluate a project consisting of the listed paths.
evaluateProject' session proxy parser paths = do
res <- runTask session $ do
res <- runTask session $ asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout $ do
blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths)
package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
modules <- topologicalSort <$> runImportGraphToModules proxy package
@ -120,9 +121,9 @@ parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
runTask', runTaskQuiet :: TaskEff a -> IO a
runTask' task = runTaskWithOptions debugOptions task >>= either (die . displayException) pure
runTaskQuiet task = runTaskWithOptions defaultOptions task >>= either (die . displayException) pure
runTask', runTaskQuiet :: ParseC TaskC a -> IO a
runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
runTaskQuiet task = runTaskWithOptions defaultOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)

5
test/Examples.hs
View File

@ -2,6 +2,7 @@
{-# OPTIONS_GHC -O1 #-}
module Main (main) where
import Control.Carrier.Parse.Measured
import Control.Effect
import Control.Effect.Reader
import Control.Exception (displayException)
@ -76,7 +77,7 @@ buildExamples session lang tsDir = do
files <- globDir1 (compile ("**/*" <> languageExtension lang)) (Path.toString (tsDir </> languageExampleDir lang))
let paths = Path.relFile <$> files
trees <- forConcurrently paths $ \file -> pure $ HUnit.testCase (Path.toString file) $ do
res <- runTask session (parseFilePath file)
res <- runTask session (runParse (parseFilePath file))
case res of
Left (SomeException e) -> case cast e of
-- We have a number of known assignment timeouts, consider these pending specs instead of failing the build.
@ -122,5 +123,5 @@ knownFailuresForPath tsDir (Just path)
)
parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Member Files sig, Carrier sig m, MonadIO m) => Path.RelFile -> m Bool
parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Member Files sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => Path.RelFile -> m Bool
parseFilePath path = readBlob (fileForRelPath path) >>= runReader (PerLanguageModes ALaCarte) . parseTermBuilder @[] TermShow . pure >>= const (pure True)

12
test/Parsing/Spec.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE TypeApplications #-}
module Parsing.Spec (spec) where
import Data.AST
import Data.Blob
import Data.ByteString.Char8 (pack)
import Data.Duration
import Data.Either
import Data.Language
import Data.Maybe
import Parsing.TreeSitter
import Source.Source
import SpecHelpers
@ -19,15 +19,15 @@ spec = do
it "returns a result when the timeout does not expire" $ do
let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout
let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar))
let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
result <- runTaskOrDie parseTask
(isJust result) `shouldBe` True
isRight result `shouldBe` True
it "returns nothing when the timeout expires" $ do
let timeout = fromMicroseconds 1000
let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar))
let parseTask = parseToAST @Grammar timeout tree_sitter_json largeBlob
result <- runTaskOrDie parseTask
(isNothing result) `shouldBe` True
isLeft result `shouldBe` True
toJSONSource :: Show a => a -> Source
toJSONSource = fromUTF8 . pack . show

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

@ -1,8 +1,10 @@
{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
module Rendering.TOC.Spec (spec) where
import Analysis.Decorator
import Analysis.TOCSummary
import Control.Effect
import Control.Effect.Parse
import Data.Aeson hiding (defaultOptions)
import Data.Bifunctor
import Data.Bifunctor.Join
@ -232,10 +234,10 @@ diffWithParser :: ( Eq1 syntax
, HasDeclaration syntax
, Hashable1 syntax
, Member Distribute sig
, Member Task sig
, Member Parse sig
, Carrier sig m
)
=> Parser (Term syntax Loc)
-> BlobPair
-> m (Diff syntax (Maybe Declaration) (Maybe Declaration))
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin
diffWithParser parser blobs = diffTermPair . runJoin <$> distributeFor blobs (\ blob -> decoratorWithAlgebra (declarationAlgebra blob) <$> parse parser blob)

3
test/Reprinting/Spec.hs
View File

@ -4,6 +4,7 @@ module Reprinting.Spec (spec) where
import SpecHelpers
import Control.Effect.Parse
import Data.Foldable
import Streaming hiding (Sum)
import qualified Streaming.Prelude as Streaming
@ -66,5 +67,5 @@ spec = describe "reprinting" $ do
let eitherPrinted = runReprinter src defaultJSONPipeline tagged
printed <- either (fail "reprinter failed") pure eitherPrinted
tree' <- runTaskOrDie (parse jsonParser (makeBlob printed path Language.JSON mempty))
tree' <- runTaskOrDie (runParseWithConfig (parse jsonParser (makeBlob printed path Language.JSON mempty)))
length tree' `shouldSatisfy` (/= 0)

9
test/Semantic/CLI/Spec.hs
View File

@ -1,5 +1,6 @@
module Semantic.CLI.Spec (testTree) where
import Control.Carrier.Parse.Simple
import Control.Effect.Reader
import Data.ByteString.Builder
import Semantic.Api hiding (Blob, BlobPair, File)
@ -33,7 +34,7 @@ renderDiff ref new = unsafePerformIO $ do
else ["git", "diff", ref, new]
{-# NOINLINE renderDiff #-}
testForDiffFixture :: (String, [BlobPair] -> TaskEff Builder, [Both File], Path.RelFile) -> TestTree
testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile) -> TestTree
testForDiffFixture (diffRenderer, runDiff, files, expected) =
goldenVsStringDiff
("diff fixture renders to " <> diffRenderer <> " " <> show files)
@ -41,7 +42,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) =
(Path.toString expected)
(fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff)
testForParseFixture :: (String, [Blob] -> TaskEff Builder, [File], Path.RelFile) -> TestTree
testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile) -> TestTree
testForParseFixture (format, runParse, files, expected) =
goldenVsStringDiff
("diff fixture renders to " <> format)
@ -49,7 +50,7 @@ testForParseFixture (format, runParse, files, expected) =
(Path.toString expected)
(fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse)
parseFixtures :: [(String, [Blob] -> TaskEff Builder, [File], Path.RelFile)]
parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile)]
parseFixtures =
[ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt")
, ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json")
@ -64,7 +65,7 @@ parseFixtures =
prefix = Path.relDir "test/fixtures/cli"
run = runReader (PerLanguageModes ALaCarte)
diffFixtures :: [(String, [BlobPair] -> TaskEff Builder, [Both File], Path.RelFile)]
diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile)]
diffFixtures =
[ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
, ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")

2
test/Semantic/Spec.hs
View File

@ -20,7 +20,7 @@ spec = do
output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n"
it "throws if given an unknown language for sexpression output" $ do
res <- runTaskWithOptions defaultOptions (runReader (PerLanguageModes ALaCarte) (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]))
res <- runTaskWithOptions defaultOptions (runReader (PerLanguageModes ALaCarte) (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob])))
case res of
Left exc -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb")
Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language"

13
test/SpecHelpers.hs
View File

@ -8,6 +8,7 @@ module SpecHelpers
, parseTestFile
, readFilePathPair
, runTaskOrDie
, runParseWithConfig
, TaskSession(..)
, testEvaluating
, toList
@ -20,6 +21,7 @@ module SpecHelpers
) where
import Control.Abstract
import Control.Carrier.Parse.Simple
import Data.Abstract.ScopeGraph (EdgeLabel(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import qualified Data.Abstract.Heap as Heap
@ -88,16 +90,19 @@ instance IsString Name where
diffFilePaths :: TaskSession -> Both Path.RelFile -> IO ByteString
diffFilePaths session paths
= readFilePathPair paths
>>= runTask session . parseDiffBuilder @[] DiffSExpression . pure
>>= runTask session . runParse (configTreeSitterParseTimeout (config session)) . parseDiffBuilder @[] DiffSExpression . pure
>>= either (die . displayException) (pure . runBuilder)
-- | Returns an s-expression parse tree for the specified path.
parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
parseFilePath session path = do
blob <- readBlobFromFile (fileForRelPath path)
res <- runTask session . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression (toList blob)
res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression (toList blob)
pure (runBuilder <$> res)
runParseWithConfig :: (Carrier sig m, Member (Reader Config) sig) => ParseC m a -> m a
runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task
-- | Read two files to a BlobPair.
readFilePathPair :: Both Path.RelFile -> IO BlobPair
readFilePathPair paths = let paths' = fmap fileForRelPath paths in
@ -110,8 +115,8 @@ parseTestFile parser path = runTaskOrDie $ do
pure (blob, term)
-- Run a Task and call `die` if it returns an Exception.
runTaskOrDie :: TaskEff a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
runTaskOrDie :: ParseC TaskC a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } (runParseWithConfig task) >>= either (die . displayException) pure
type TestEvaluatingC term
= ResumableC (BaseError (AddressError Precise (Val term)))