From a1511f2a4d596dc08e7053b62d2ccfd313d14caa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 09:56:10 -0400 Subject: [PATCH 01/94] Define a SomeParser type abstracting a parser over a given constraint on its terms. --- src/Semantic/Api/Terms.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 75f95f293..327e87ce4 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, MonoLocalBinds, RankNTypes #-} +{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes #-} module Semantic.Api.Terms ( termGraph , parseTermBuilder @@ -151,3 +151,7 @@ doParse with blob = case blobLanguage blob of TSX -> parse tsxParser blob >>= with PHP -> parse phpParser blob >>= with _ -> noLanguageForBlob (blobPath blob) + + +data SomeParser c a where + SomeParser :: c t => Parser (t a) -> SomeParser c a From 1e35fcf8e87e2e67795a13bda68bd395fbfc4117 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 09:56:30 -0400 Subject: [PATCH 02/94] Define the list of parsers for the ShowTerm feature. --- src/Semantic/Api/Terms.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 327e87ce4..c869c7476 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -155,3 +155,22 @@ doParse with blob = case blobLanguage blob of data SomeParser c a where SomeParser :: c t => Parser (t a) -> SomeParser c a + +showTermParsers + :: (Carrier sig m, Member (Reader PerLanguageModes) sig) + => m [(Language, SomeParser ShowTerm Loc)] +showTermParsers = ask >>= \ modes -> pure + [ (Go, SomeParser goParser) + , (Haskell, SomeParser haskellParser) + , (JavaScript, SomeParser tsxParser) + , (JSON, SomeParser jsonParser) + , (JSX, SomeParser tsxParser) + , (Markdown, SomeParser markdownParser) + , (Python, case pythonMode modes of + ALaCarte -> SomeParser pythonParser + Precise -> SomeParser precisePythonParser) + , (Ruby, SomeParser rubyParser) + , (TypeScript, SomeParser typescriptParser) + , (TSX, SomeParser tsxParser) + , (PHP, SomeParser phpParser) + ] From fe13a6c56083ebea9beab9a2c9304b1fd85ef853 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 09:56:42 -0400 Subject: [PATCH 03/94] Define a helper to parse using a given list of parsers. --- src/Semantic/Api/Terms.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index c869c7476..a7996e07b 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -174,3 +174,13 @@ showTermParsers = ask >>= \ modes -> pure , (TSX, SomeParser tsxParser) , (PHP, SomeParser phpParser) ] + +doParse' + :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) + => [(Language, SomeParser c ann)] + -> (forall term . c term => term ann -> m a) + -> Blob + -> m a +doParse' parsers with blob = case lookup (blobLanguage blob) parsers of + Just (SomeParser parser) -> parse parser blob >>= with + _ -> noLanguageForBlob (blobPath blob) From e71e1fcca103a861ae084825aa7ccd690e34d971 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 09:56:57 -0400 Subject: [PATCH 04/94] Show terms using showTermParsers/doParse'. --- src/Semantic/Api/Terms.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index a7996e07b..47f069eec 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -64,7 +64,7 @@ parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Form parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm) parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) -parseTermBuilder TermShow = distributeFoldMap (doParse showTerm) +parseTermBuilder TermShow = distributeFoldMap (\ blob -> showTermParsers >>= \ parsers -> doParse' parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) @@ -74,7 +74,7 @@ jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "t jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder -quietTerm blob = showTiming blob <$> time' ( doParse (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) +quietTerm blob = showTiming blob <$> time' ( showTermParsers >>= \ parsers -> doParse' parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) where timingError (SomeException e) = pure (Left (show e)) showTiming Blob{..} (res, duration) = @@ -128,7 +128,7 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t, ShowTerm t) +type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t) doParse :: ( Carrier sig m From 3026e6210b2257be1a761fd1eecb926dd6fe3303 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:32:57 -0400 Subject: [PATCH 05/94] Add separators to the haddocks. --- src/Parsing/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 3443805fd..1f9cc63e1 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -6,7 +6,7 @@ module Parsing.Parser , someASTParser , someAnalysisParser , ApplyAll --- À la carte parsers +-- * À la carte parsers , goParser , goASTParser , jsonParser @@ -21,7 +21,7 @@ module Parsing.Parser , phpParser , phpASTParser , haskellParser - -- Precise parsers + -- * Precise parsers , precisePythonParser ) where From e3e14a666b5a9bb7d5ab953b81d2c782ee69fce6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:45:53 -0400 Subject: [PATCH 06/94] Move SomeParser to Parsing.Parser. --- src/Parsing/Parser.hs | 2 ++ src/Semantic/Api/Terms.hs | 3 --- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 1f9cc63e1..751e1f41d 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -23,6 +23,8 @@ module Parsing.Parser , haskellParser -- * Precise parsers , precisePythonParser + -- * Abstract parsers +, SomeParser(..) ) where import Assigning.Assignment diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 47f069eec..c98ad109a 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -153,9 +153,6 @@ doParse with blob = case blobLanguage blob of _ -> noLanguageForBlob (blobPath blob) -data SomeParser c a where - SomeParser :: c t => Parser (t a) -> SomeParser c a - showTermParsers :: (Carrier sig m, Member (Reader PerLanguageModes) sig) => m [(Language, SomeParser ShowTerm Loc)] From 7fdeb90f6bf6059c7d82ecac04e5d707e43b26cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:46:15 -0400 Subject: [PATCH 07/94] Define abstracted parsers. --- src/Parsing/Parser.hs | 58 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 751e1f41d..ba8c8ccf3 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -25,6 +25,19 @@ module Parsing.Parser , precisePythonParser -- * Abstract parsers , SomeParser(..) +, goParser' +, haskellParser' +, javascriptParser' +, jsonParser' +, jsxParser' +, markdownParser' +, phpParser' +, pythonParserALaCarte' +, pythonParserPrecise' +, pythonParser' +, rubyParser' +, typescriptParser' +, tsxParser' ) where import Assigning.Assignment @@ -191,3 +204,48 @@ someASTParser PHP = Just (SomeASTParser (ASTParser tree_sitter_php :: Par someASTParser Java = Nothing someASTParser Markdown = Nothing someASTParser Unknown = Nothing + + +data SomeParser c a where + SomeParser :: c t => Parser (t a) -> SomeParser c a + +goParser' :: c (Term (Sum Go.Syntax)) => (Language, SomeParser c Loc) +goParser' = (Go, SomeParser goParser) + +haskellParser' :: c (Term (Sum Haskell.Syntax)) => (Language, SomeParser c Loc) +haskellParser' = (Haskell, SomeParser haskellParser) + +javascriptParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +javascriptParser' = (JavaScript, SomeParser tsxParser) + +jsonParser' :: c (Term (Sum JSON.Syntax)) => (Language, SomeParser c Loc) +jsonParser' = (JSON, SomeParser jsonParser) + +jsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +jsxParser' = (JSX, SomeParser tsxParser) + +markdownParser' :: c (Term (Sum Markdown.Syntax)) => (Language, SomeParser c Loc) +markdownParser' = (Markdown, SomeParser markdownParser) + +phpParser' :: c (Term (Sum PHP.Syntax)) => (Language, SomeParser c Loc) +phpParser' = (PHP, SomeParser phpParser) + +pythonParserALaCarte' :: c (Term (Sum Python.Syntax)) => (Language, SomeParser c Loc) +pythonParserALaCarte' = (Python, SomeParser pythonParser) + +pythonParserPrecise' :: c Py.Term => (Language, SomeParser c Loc) +pythonParserPrecise' = (Python, SomeParser precisePythonParser) + +pythonParser' :: (c (Term (Sum Python.Syntax)), c Py.Term) => PerLanguageModes -> (Language, SomeParser c Loc) +pythonParser' modes = case pythonMode modes of + ALaCarte -> (Python, SomeParser pythonParser) + Precise -> (Python, SomeParser precisePythonParser) + +rubyParser' :: c (Term (Sum Ruby.Syntax)) => (Language, SomeParser c Loc) +rubyParser' = (Ruby, SomeParser rubyParser) + +typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc) +typescriptParser' = (TypeScript, SomeParser typescriptParser) + +tsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) +tsxParser' = (TSX, SomeParser tsxParser) From 3e137ae384832925679b2317601f3bdfc0b07217 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:47:53 -0400 Subject: [PATCH 08/94] Use the abstracted parsers to define showTermParsers. --- src/Semantic/Api/Terms.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index c98ad109a..5681f4c31 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -157,19 +157,17 @@ showTermParsers :: (Carrier sig m, Member (Reader PerLanguageModes) sig) => m [(Language, SomeParser ShowTerm Loc)] showTermParsers = ask >>= \ modes -> pure - [ (Go, SomeParser goParser) - , (Haskell, SomeParser haskellParser) - , (JavaScript, SomeParser tsxParser) - , (JSON, SomeParser jsonParser) - , (JSX, SomeParser tsxParser) - , (Markdown, SomeParser markdownParser) - , (Python, case pythonMode modes of - ALaCarte -> SomeParser pythonParser - Precise -> SomeParser precisePythonParser) - , (Ruby, SomeParser rubyParser) - , (TypeScript, SomeParser typescriptParser) - , (TSX, SomeParser tsxParser) - , (PHP, SomeParser phpParser) + [ goParser' + , haskellParser' + , javascriptParser' + , jsonParser' + , jsxParser' + , markdownParser' + , phpParser' + , pythonParser' modes + , rubyParser' + , typescriptParser' + , tsxParser' ] doParse' From 5309eed607dce05458106a93e27fbf1d3f478b7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:48:41 -0400 Subject: [PATCH 09/94] Move showTermParsers adjacent to ShowTerm. --- src/Semantic/Api/Terms.hs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 5681f4c31..231489ac5 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -85,6 +85,23 @@ quietTerm blob = showTiming blob <$> time' ( showTermParsers >>= \ parsers -> do type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m) +showTermParsers + :: (Carrier sig m, Member (Reader PerLanguageModes) sig) + => m [(Language, SomeParser ShowTerm Loc)] +showTermParsers = ask >>= \ modes -> pure + [ goParser' + , haskellParser' + , javascriptParser' + , jsonParser' + , jsxParser' + , markdownParser' + , phpParser' + , pythonParser' modes + , rubyParser' + , typescriptParser' + , tsxParser' + ] + class ShowTerm term where showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder @@ -153,23 +170,6 @@ doParse with blob = case blobLanguage blob of _ -> noLanguageForBlob (blobPath blob) -showTermParsers - :: (Carrier sig m, Member (Reader PerLanguageModes) sig) - => m [(Language, SomeParser ShowTerm Loc)] -showTermParsers = ask >>= \ modes -> pure - [ goParser' - , haskellParser' - , javascriptParser' - , jsonParser' - , jsxParser' - , markdownParser' - , phpParser' - , pythonParser' modes - , rubyParser' - , typescriptParser' - , tsxParser' - ] - doParse' :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => [(Language, SomeParser c ann)] From d168e391ef043ba16341be372c2688f908c7b807 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 10:49:32 -0400 Subject: [PATCH 10/94] Rename doParse' to parseWith. --- src/Semantic/Api/Terms.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 231489ac5..9315a73bf 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -64,7 +64,7 @@ parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Form parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm) parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) -parseTermBuilder TermShow = distributeFoldMap (\ blob -> showTermParsers >>= \ parsers -> doParse' parsers showTerm blob) +parseTermBuilder TermShow = distributeFoldMap (\ blob -> showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) @@ -74,7 +74,7 @@ jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "t jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder -quietTerm blob = showTiming blob <$> time' ( showTermParsers >>= \ parsers -> doParse' parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) +quietTerm blob = showTiming blob <$> time' ( showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) where timingError (SomeException e) = pure (Left (show e)) showTiming Blob{..} (res, duration) = @@ -170,12 +170,12 @@ doParse with blob = case blobLanguage blob of _ -> noLanguageForBlob (blobPath blob) -doParse' +parseWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => [(Language, SomeParser c ann)] -> (forall term . c term => term ann -> m a) -> Blob -> m a -doParse' parsers with blob = case lookup (blobLanguage blob) parsers of +parseWith parsers with blob = case lookup (blobLanguage blob) parsers of Just (SomeParser parser) -> parse parser blob >>= with _ -> noLanguageForBlob (blobPath blob) From 316e6ad0aa2c7a20becb4b413263d658dbe1e63e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:13:53 -0400 Subject: [PATCH 11/94] Replace annotations with () in Python terms. --- src/Semantic/Api/Terms.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 9315a73bf..f3c442619 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -109,7 +109,7 @@ instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where showTerm = serialize Show . quieterm instance ShowTerm Py.Term where - showTerm = serialize Show . Py.getTerm + showTerm = serialize Show . (() <$) . Py.getTerm class SExprTerm term where From d7d71f2ba5caaba019e77404ddc10d811606b180 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:18:51 -0400 Subject: [PATCH 12/94] List the SExprTerm parsers. --- src/Semantic/Api/Terms.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index f3c442619..51dfd9ef5 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -112,6 +112,21 @@ instance ShowTerm Py.Term where showTerm = serialize Show . (() <$) . Py.getTerm +sexprTermParsers :: [(Language, SomeParser SExprTerm Loc)] +sexprTermParsers = + [ goParser' + , haskellParser' + , javascriptParser' + , jsonParser' + , jsxParser' + , markdownParser' + , phpParser' + , pythonParserALaCarte' + , rubyParser' + , typescriptParser' + , tsxParser' + ] + class SExprTerm term where sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder From 2e9213bfdad6bf2d3b50e199fb70457b9734e26b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:19:48 -0400 Subject: [PATCH 13/94] Use parseWith for SExprTerm. --- src/Semantic/Api/Terms.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 51dfd9ef5..b044ecbc8 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -62,7 +62,7 @@ parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, M => TermOutputFormat -> t Blob -> m Builder parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs. parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON -parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm) +parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers sexprTerm) parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) parseTermBuilder TermShow = distributeFoldMap (\ blob -> showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm @@ -160,7 +160,7 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t) +type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t) doParse :: ( Carrier sig m From 0307f7e536abe6dd316e6459d43079a4cb81078e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:22:43 -0400 Subject: [PATCH 14/94] Alphabetize. --- src/Parsing/Parser.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index ba8c8ccf3..cb6026d80 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -36,8 +36,8 @@ module Parsing.Parser , pythonParserPrecise' , pythonParser' , rubyParser' -, typescriptParser' , tsxParser' +, typescriptParser' ) where import Assigning.Assignment @@ -244,8 +244,8 @@ pythonParser' modes = case pythonMode modes of rubyParser' :: c (Term (Sum Ruby.Syntax)) => (Language, SomeParser c Loc) rubyParser' = (Ruby, SomeParser rubyParser) -typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc) -typescriptParser' = (TypeScript, SomeParser typescriptParser) - tsxParser' :: c (Term (Sum TSX.Syntax)) => (Language, SomeParser c Loc) tsxParser' = (TSX, SomeParser tsxParser) + +typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc) +typescriptParser' = (TypeScript, SomeParser typescriptParser) From 1b46f40e8f5e0861d055ad05f055985f60499e94 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:23:27 -0400 Subject: [PATCH 15/94] =?UTF-8?q?List=20the=20canonical=20=C3=A0=20la=20ca?= =?UTF-8?q?rte=20parsers.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Parsing/Parser.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index cb6026d80..09723f2a7 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -38,6 +38,8 @@ module Parsing.Parser , rubyParser' , tsxParser' , typescriptParser' + -- * Canonical sets of parsers +, aLaCarteParsers ) where import Assigning.Assignment @@ -249,3 +251,30 @@ tsxParser' = (TSX, SomeParser tsxParser) typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c Loc) typescriptParser' = (TypeScript, SomeParser typescriptParser) + + +aLaCarteParsers + :: ( c (Term (Sum Go.Syntax)) + , c (Term (Sum Haskell.Syntax)) + , c (Term (Sum JSON.Syntax)) + , c (Term (Sum Markdown.Syntax)) + , c (Term (Sum PHP.Syntax)) + , c (Term (Sum Python.Syntax)) + , c (Term (Sum Ruby.Syntax)) + , c (Term (Sum TSX.Syntax)) + , c (Term (Sum TypeScript.Syntax)) + ) + => [(Language, SomeParser c Loc)] +aLaCarteParsers = + [ goParser' + , haskellParser' + , javascriptParser' + , jsonParser' + , jsxParser' + , markdownParser' + , phpParser' + , pythonParserALaCarte' + , rubyParser' + , typescriptParser' + , tsxParser' + ] From b33b98e75c7bce09af1523c9b715acc643496c3c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 2 Oct 2019 11:22:14 -0400 Subject: [PATCH 16/94] Remove FileCheck conversion of Core to JSON. Converting Core into JSON and querying it turned out to be an exercise in frustration, since Core does not map naturally onto JSON. Indeed, we have given up using it entirely thanks to the `CHECK-TREE` directive, which is much more natural. This means we can drop it from the test harness and remove the orphan instances that allowed it. --- semantic-python/test/Instances.hs | 58 ------------------------------- semantic-python/test/Test.hs | 1 - 2 files changed, 59 deletions(-) diff --git a/semantic-python/test/Instances.hs b/semantic-python/test/Instances.hs index 3d5f52482..d7d672b9a 100644 --- a/semantic-python/test/Instances.hs +++ b/semantic-python/test/Instances.hs @@ -21,64 +21,6 @@ import Data.Scope (Scope, Incr) import qualified Data.Scope as Scope import Data.Name -instance ToJSON a => ToJSON (Named a) where - toJSON _ = object [] - -instance ToJSON1 Named where - liftToJSON f _ (Named i a) = object - [ "name" .= i - , "value" .= f a - ] - - -- Loses information compared to the toJSON instance - -- due to an infelicity in how Aeson's toJSON1 is implemented. - -- The correct thing to do here is to manually munge the bytestring - -- together as a builder, but we don't even hit this code path, - -- so it will do for now. - liftToEncoding f _ (Named _name a) = f a - -instance ToJSON2 Incr where - liftToJSON2 f _ g _ = \case - Scope.Z a -> f a - Scope.S b -> g b - liftToEncoding2 f _ g _ = \case - Scope.Z a -> f a - Scope.S b -> g b - -deriving newtype instance (ToJSON a) => ToJSON (Ignored a) - -instance (Functor f, ToJSON1 f, ToJSON a) => ToJSON1 (Scope a f) where - liftToJSON f g (Scope.Scope a) = toJSON1 (fmap (toJSON2 . fmap (liftToJSON f g)) a) - liftToEncoding f g (Scope.Scope a) = liftToEncoding inner outer a where - inner = liftToEncoding2 toEncoding toEncodingList hoist loist - outer = liftToEncodingList2 toEncoding toEncodingList hoist loist - hoist = liftToEncoding f g - loist = liftToEncodingList f g - -deriving anyclass instance (Functor f, ToJSON1 f) => ToJSON1 (Core f) - -instance (ToJSON1 (sig (Term sig))) => ToJSON1 (Term sig) where - liftToJSON f _ (Var a) = f a - liftToJSON f g (Term s) = liftToJSON f g s - - liftToEncoding f _ (Var a) = f a - liftToEncoding f g (Term s) = liftToEncoding f g s - -instance (ToJSON1 (f k), ToJSON1 (g k)) => ToJSON1 ((:+:) f g k) where - liftToJSON f g (L h) = liftToJSON f g h - liftToJSON f g (R h) = liftToJSON f g h - - liftToEncoding f g (L h) = liftToEncoding f g h - liftToEncoding f g (R h) = liftToEncoding f g h - -instance (ToJSON1 f) => ToJSON1 (Ann f) where - liftToJSON f g (Ann loc term) = - let - rest = case liftToJSON f g term of - Object os -> HashMap.toList os - other -> ["value" .= other] - in object (["location" .= loc] <> rest) - -- We default to deriving the default toEncoding definition (that piggybacks -- off of toJSON) so that we never hit the problematic code paths associated -- with toEncoding above. diff --git a/semantic-python/test/Test.hs b/semantic-python/test/Test.hs index 202dbf42b..eaee4a23a 100644 --- a/semantic-python/test/Test.hs +++ b/semantic-python/test/Test.hs @@ -56,7 +56,6 @@ assertJQExpressionSucceeds directive tree core = do (heap, [File _ (Right result)]) -> pure $ Aeson.object [ "scope" Aeson..= heap , "heap" Aeson..= result - , "tree" Aeson..= Aeson.toJSON1 core ] _other -> HUnit.assertFailure "Couldn't run scope dumping mechanism; this shouldn't happen" From 7aee07b3ec6a59ae3f60e4072ffdaacd6e14f5f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:24:37 -0400 Subject: [PATCH 17/94] List all the canonical parsers. --- src/Parsing/Parser.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 09723f2a7..22f6e5520 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -40,6 +40,7 @@ module Parsing.Parser , typescriptParser' -- * Canonical sets of parsers , aLaCarteParsers +, allParsers ) where import Assigning.Assignment @@ -278,3 +279,31 @@ aLaCarteParsers = , typescriptParser' , tsxParser' ] + +allParsers + :: ( c (Term (Sum Go.Syntax)) + , c (Term (Sum Haskell.Syntax)) + , c (Term (Sum JSON.Syntax)) + , c (Term (Sum Markdown.Syntax)) + , c (Term (Sum PHP.Syntax)) + , c (Term (Sum Python.Syntax)) + , c Py.Term + , c (Term (Sum Ruby.Syntax)) + , c (Term (Sum TSX.Syntax)) + , c (Term (Sum TypeScript.Syntax)) + ) + => PerLanguageModes + -> [(Language, SomeParser c Loc)] +allParsers modes = + [ goParser' + , haskellParser' + , javascriptParser' + , jsonParser' + , jsxParser' + , markdownParser' + , phpParser' + , pythonParser' modes + , rubyParser' + , typescriptParser' + , tsxParser' + ] From 035f26725fd331518568b09ff63bf6cc9cbba73b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:26:11 -0400 Subject: [PATCH 18/94] List the canonical precise parsers. --- src/Parsing/Parser.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 22f6e5520..4ee5f736b 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -40,6 +40,7 @@ module Parsing.Parser , typescriptParser' -- * Canonical sets of parsers , aLaCarteParsers +, preciseParsers , allParsers ) where @@ -280,6 +281,11 @@ aLaCarteParsers = , tsxParser' ] +preciseParsers :: c Py.Term => [(Language, SomeParser c Loc)] +preciseParsers = + [ pythonParserPrecise' + ] + allParsers :: ( c (Term (Sum Go.Syntax)) , c (Term (Sum Haskell.Syntax)) From d8b99b9cb1824bf33ff7f81b0c3e202c6fe178fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:27:13 -0400 Subject: [PATCH 19/94] =?UTF-8?q?Use=20the=20canonical=20listing=20of=20?= =?UTF-8?q?=C3=A0=20la=20carte=20parsers=20for=20sexprTermParsers.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Api/Terms.hs | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index b044ecbc8..5c898427f 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -113,19 +113,7 @@ instance ShowTerm Py.Term where sexprTermParsers :: [(Language, SomeParser SExprTerm Loc)] -sexprTermParsers = - [ goParser' - , haskellParser' - , javascriptParser' - , jsonParser' - , jsxParser' - , markdownParser' - , phpParser' - , pythonParserALaCarte' - , rubyParser' - , typescriptParser' - , tsxParser' - ] +sexprTermParsers = aLaCarteParsers class SExprTerm term where sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder From f32c25b01aa7f9f5da74d2b987822185fbdb9b7f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:36:14 -0400 Subject: [PATCH 20/94] Define showTermParsers as a function, rather than in a monad. --- src/Semantic/Api/Terms.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 5c898427f..014202e91 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -64,7 +64,7 @@ parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Form parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers sexprTerm) parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) -parseTermBuilder TermShow = distributeFoldMap (\ blob -> showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) +parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) @@ -74,7 +74,7 @@ jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "t jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder -quietTerm blob = showTiming blob <$> time' ( showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) +quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) where timingError (SomeException e) = pure (Left (show e)) showTiming Blob{..} (res, duration) = @@ -86,9 +86,9 @@ type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerL showTermParsers - :: (Carrier sig m, Member (Reader PerLanguageModes) sig) - => m [(Language, SomeParser ShowTerm Loc)] -showTermParsers = ask >>= \ modes -> pure + :: PerLanguageModes + -> [(Language, SomeParser ShowTerm Loc)] +showTermParsers modes = [ goParser' , haskellParser' , javascriptParser' From 5013f3bfcabd61e5368339354e6c71841b0e02a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:37:35 -0400 Subject: [PATCH 21/94] Define showTermParsers using allParsers. --- src/Semantic/Api/Terms.hs | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 014202e91..358508ebc 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -85,22 +85,8 @@ quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m) -showTermParsers - :: PerLanguageModes - -> [(Language, SomeParser ShowTerm Loc)] -showTermParsers modes = - [ goParser' - , haskellParser' - , javascriptParser' - , jsonParser' - , jsxParser' - , markdownParser' - , phpParser' - , pythonParser' modes - , rubyParser' - , typescriptParser' - , tsxParser' - ] +showTermParsers :: PerLanguageModes -> [(Language, SomeParser ShowTerm Loc)] +showTermParsers = allParsers class ShowTerm term where showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder From b0b419bf6effda201bcc46e13c91a7dd06b67015 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:39:48 -0400 Subject: [PATCH 22/94] Use parseWith for DOTGraphTerm. --- src/Semantic/Api/Terms.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 358508ebc..a41d5cb25 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -63,7 +63,7 @@ parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, M parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs. parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers sexprTerm) -parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm) +parseTermBuilder TermDotGraph = distributeFoldMap (parseWith dotGraphTermParsers dotGraphTerm) parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm @@ -108,6 +108,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm sexprTerm = serialize (SExpression ByConstructorName) +dotGraphTermParsers :: [(Language, SomeParser DOTGraphTerm Loc)] +dotGraphTermParsers = aLaCarteParsers + class DOTGraphTerm term where dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder @@ -134,7 +137,7 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t) +type TermActions t = (JSONGraphTerm t, JSONTreeTerm t) doParse :: ( Carrier sig m From 41652c96abf5385c64b46472e1640582aaa5f199 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:41:21 -0400 Subject: [PATCH 23/94] Use parseWith for JSONTreeTerm. --- src/Semantic/Api/Terms.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index a41d5cb25..7bbaa1360 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -68,7 +68,7 @@ parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermPar parseTermBuilder TermQuiet = distributeFoldMap quietTerm jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) -jsonTerm blob = doParse (pure . jsonTreeTerm blob) blob `catchError` jsonError blob +jsonTerm blob = parseWith jsonTreeTermParsers (pure . jsonTreeTerm blob) blob `catchError` jsonError blob jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) @@ -118,6 +118,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTe dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph +jsonTreeTermParsers :: [(Language, SomeParser JSONTreeTerm Loc)] +jsonTreeTermParsers = aLaCarteParsers + class JSONTreeTerm term where jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON @@ -137,7 +140,7 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -type TermActions t = (JSONGraphTerm t, JSONTreeTerm t) +type TermActions t = JSONGraphTerm t doParse :: ( Carrier sig m From 837916e9228a0c2728a9d17585dea1a4c66efd91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:43:40 -0400 Subject: [PATCH 24/94] Use parseWith for JSONGraphTerm. --- src/Semantic/Api/Terms.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 7bbaa1360..8a276093d 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -41,7 +41,7 @@ termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blo termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go where go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph - go blob = doParse (pure . jsonGraphTerm blob) blob + go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob `catchError` \(SomeException e) -> pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where @@ -128,6 +128,9 @@ instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where jsonTreeTerm = renderJSONTerm +jsonGraphTermParsers :: [(Language, SomeParser JSONGraphTerm Loc)] +jsonGraphTermParsers = aLaCarteParsers + class JSONGraphTerm term where jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph @@ -140,14 +143,12 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -type TermActions t = JSONGraphTerm t - doParse :: ( Carrier sig m , Member (Error SomeException) sig , Member Parse sig ) - => (forall term . TermActions term => term Loc -> m a) + => (forall term . term Loc -> m a) -> Blob -> m a doParse with blob = case blobLanguage blob of From fc9a5790855679028ac1fda1ee7063bf31c07012 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:44:29 -0400 Subject: [PATCH 25/94] :fire: doParse. --- src/Semantic/Api/Terms.hs | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 8a276093d..370a4edb8 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -143,29 +143,6 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT lang = bridging # blobLanguage blob -doParse - :: ( Carrier sig m - , Member (Error SomeException) sig - , Member Parse sig - ) - => (forall term . term Loc -> m a) - -> Blob - -> m a -doParse with blob = case blobLanguage blob of - Go -> parse goParser blob >>= with - Haskell -> parse haskellParser blob >>= with - JavaScript -> parse tsxParser blob >>= with - JSON -> parse jsonParser blob >>= with - JSX -> parse tsxParser blob >>= with - Markdown -> parse markdownParser blob >>= with - Python -> parse pythonParser blob >>= with - Ruby -> parse rubyParser blob >>= with - TypeScript -> parse typescriptParser blob >>= with - TSX -> parse tsxParser blob >>= with - PHP -> parse phpParser blob >>= with - _ -> noLanguageForBlob (blobPath blob) - - parseWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => [(Language, SomeParser c ann)] From b285e612d9eb9f099ac121bdb1f9864fd8d30429 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:46:54 -0400 Subject: [PATCH 26/94] Move parseWith into Control.Effect.Parse. --- src/Control/Effect/Parse.hs | 17 ++++++++++++++++- src/Semantic/Api/Terms.hs | 11 ----------- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index c9bf9a775..d5832b381 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, RankNTypes #-} module Control.Effect.Parse ( -- * Parse effect Parse(..) , parse +, parseWith ) where import Control.Effect.Carrier +import Control.Effect.Error +import Control.Exception (SomeException) import Data.Blob +import Data.Language import Parsing.Parser data Parse m k @@ -27,3 +31,14 @@ parse :: (Member Parse sig, Carrier sig m) -> Blob -> m term parse parser blob = send (Parse parser blob pure) + + +parseWith + :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) + => [(Language, SomeParser c ann)] + -> (forall term . c term => term ann -> m a) + -> Blob + -> m a +parseWith parsers with blob = case lookup (blobLanguage blob) parsers of + Just (SomeParser parser) -> parse parser blob >>= with + _ -> noLanguageForBlob (blobPath blob) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 370a4edb8..3c75d9ea9 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -141,14 +141,3 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphT in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where path = T.pack $ blobPath blob lang = bridging # blobLanguage blob - - -parseWith - :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => [(Language, SomeParser c ann)] - -> (forall term . c term => term ann -> m a) - -> Blob - -> m a -parseWith parsers with blob = case lookup (blobLanguage blob) parsers of - Just (SomeParser parser) -> parse parser blob >>= with - _ -> noLanguageForBlob (blobPath blob) From 9f97649a33cc3dc049f1713bf9edd9c4ff89ed6a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 11:57:26 -0400 Subject: [PATCH 27/94] Swap the order of the source & symbols to summarize params. --- src/Semantic/Api/Symbols.hs | 2 +- src/Tags/Tagging.hs | 4 ++-- test/Tags/Spec.hs | 30 +++++++++++++++--------------- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 9aabbe786..46c3871f4 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -93,7 +93,7 @@ tagToSymbol Tag{..} = Symbol data ALaCarteTerm syntax ann = ALaCarteTerm Language [Text] (Term syntax ann) instance IsTaggable syntax => Precise.ToTags (ALaCarteTerm syntax) where - tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang source symbolsToSummarize term + tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang symbolsToSummarize source term doParse diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 46a5de3ef..4657bb473 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -23,11 +23,11 @@ import Tags.Taggable runTagging :: (IsTaggable syntax) => Language - -> Source.Source -> [Text] + -> Source.Source -> Term syntax Loc -> [Tag] -runTagging lang source symbolsToSummarize +runTagging lang symbolsToSummarize source = Eff.run . evalState @[ContextToken] [] . Streaming.toList_ diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 24089583c..cc13d2c40 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -10,40 +10,40 @@ spec = do describe "go" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "TestFromBits" Function (Span (Pos 6 1) (Pos 8 2)) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...") , Tag "Hi" Function (Span (Pos 10 1) (Pos 11 2)) "func Hi()" Nothing ] it "produces tags for methods" $ do (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/method.go") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "CheckAuth" Method (Span (Pos 3 1) (Pos 3 100)) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing] it "produces tags for calls" $ do (blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go") - runTagging (blobLanguage blob) (blobSource blob) ["Call"] tree `shouldBe` + runTagging (blobLanguage blob) ["Call"] (blobSource blob) tree `shouldBe` [ Tag "Hi" Call (Span (Pos 7 2) (Pos 7 6)) "Hi()" Nothing] describe "javascript and typescript" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/javascript/tags/simple_function_with_docs.js") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "myFunction" Function (Span (Pos 2 1) (Pos 4 2)) "function myFunction()" (Just "// This is myFunction") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/class.ts") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "FooBar" Class (Span (Pos 1 1) (Pos 1 16)) "class FooBar" Nothing ] it "produces tags for modules" $ do (blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/module.ts") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "APromise" Tags.Module (Span (Pos 1 1) (Pos 1 20)) "module APromise { }" Nothing ] describe "python" $ do it "produces tags for functions" $ do (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_functions.py") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "Foo" Function (Span (Pos 1 1) (Pos 5 17)) "def Foo(x):" Nothing , Tag "Bar" Function (Span (Pos 7 1) (Pos 11 13)) "def Bar():" Nothing , Tag "local" Function (Span (Pos 8 5) (Pos 9 17)) "def local():" Nothing @@ -51,30 +51,30 @@ spec = do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_function_with_docs.py") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/class.py") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "Foo" Class (Span (Pos 1 1) (Pos 5 17)) "class Foo:" (Just "\"\"\"The Foo class\"\"\"") , Tag "f" Function (Span (Pos 3 5) (Pos 5 17)) "def f(self):" (Just "\"\"\"The f method\"\"\"") ] it "produces tags for multi-line functions" $ do (blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/multiline.py") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x," Nothing ] describe "ruby" $ do it "produces tags for methods" $ do (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "foo" Method (Span (Pos 1 1) (Pos 4 4)) "def foo" Nothing ] it "produces tags for sends" $ do (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb") - runTagging (blobLanguage blob) (blobSource blob) ["Send"] tree `shouldBe` + runTagging (blobLanguage blob) ["Send"] (blobSource blob) tree `shouldBe` [ Tag "puts" Call (Span (Pos 2 3) (Pos 2 12)) "puts \"hi\"" Nothing , Tag "bar" Call (Span (Pos 3 3) (Pos 3 8)) "a.bar" Nothing , Tag "a" Call (Span (Pos 3 3) (Pos 3 4)) "a" Nothing @@ -82,17 +82,17 @@ spec = do it "produces tags for methods with docs" $ do (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method_with_docs.rb") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "foo" Method (Span (Pos 2 1) (Pos 3 4)) "def foo" (Just "# Public: foo") ] it "correctly tags files containing multibyte UTF-8 characters" $ do (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/unicode_identifiers.rb") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "日本語" Method (Span (Pos 2 1) (Pos 4 4)) "def 日本語" (Just "# coding: utf-8")] it "produces tags for methods and classes with docs" $ do (blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/class_module.rb") - runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe` + runTagging (blobLanguage blob) symbolsToSummarize (blobSource blob) tree `shouldBe` [ Tag "Foo" Tags.Module (Span (Pos 2 1 ) (Pos 12 4)) "module Foo" (Just "# Public: Foo") , Tag "Bar" Class (Span (Pos 5 3 ) (Pos 11 6)) "class Bar" (Just "# Public: Bar") , Tag "baz" Method (Span (Pos 8 5 ) (Pos 10 8)) "def baz(a)" (Just "# Public: baz") From 7454477ecc3fa9f72e924d46c4b624b8f966661a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:01:06 -0400 Subject: [PATCH 28/94] Compute tags via a more general interface. This allows us to :fire: ALaCarteTerm. --- src/Semantic/Api/Symbols.hs | 53 ++++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 25 deletions(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 46c3871f4..cc94f5009 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -17,6 +17,7 @@ import Data.Term import qualified Data.Text as T import qualified Data.Vector as V import Data.Text (pack) +import qualified Language.Python as Python import qualified Parsing.Parser as Parser import Prologue import Semantic.Api.Bridge @@ -26,6 +27,7 @@ import Semantic.Config import Semantic.Task import Serializing.Format (Format) import Source.Loc +import Source.Source import Tags.Taggable import Tags.Tagging import qualified Tags.Tagging.Precise as Precise @@ -34,7 +36,7 @@ legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs where go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File] - go blob@Blob{..} = doParse (pure . renderToSymbols) symbolsToSummarize blob `catchError` (\(SomeException _) -> pure (pure emptyFile)) + go blob@Blob{..} = doParse (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = tagsToFile [] @@ -42,8 +44,8 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap symbolsToSummarize :: [Text] symbolsToSummarize = ["Function", "Method", "Class", "Module"] - renderToSymbols :: Precise.ToTags t => t Loc -> [Legacy.File] - renderToSymbols = pure . tagsToFile . Precise.tags blobSource + renderToSymbols :: ToTags t => t Loc -> [Legacy.File] + renderToSymbols = pure . tagsToFile . tags (blobLanguage blob) symbolsToSummarize blobSource tagsToFile :: [Tag] -> Legacy.File tagsToFile tags = Legacy.File (pack (blobPath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags) @@ -64,15 +66,15 @@ parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go where go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File - go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) symbolsToSummarize blob + go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) blob where catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e)) blobLanguage' = blobLanguage blob blobPath' = pack $ blobPath blob errorFile e = File blobPath' (bridging # blobLanguage') mempty (V.fromList [ParseError (T.pack e)]) blobOid - renderToSymbols :: Precise.ToTags t => t Loc -> File - renderToSymbols term = tagsToFile (Precise.tags blobSource term) + renderToSymbols :: ToTags t => t Loc -> File + renderToSymbols term = tagsToFile (tags (blobLanguage blob) symbolsToSummarize blobSource term) tagsToFile :: [Tag] -> File tagsToFile tags = File blobPath' (bridging # blobLanguage') (V.fromList (fmap tagToSymbol tags)) mempty blobOid @@ -90,10 +92,14 @@ tagToSymbol Tag{..} = Symbol } -data ALaCarteTerm syntax ann = ALaCarteTerm Language [Text] (Term syntax ann) +class ToTags t where + tags :: Language -> [Text] -> Source -> t Loc -> [Tag] -instance IsTaggable syntax => Precise.ToTags (ALaCarteTerm syntax) where - tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang symbolsToSummarize source term +instance IsTaggable syntax => ToTags (Term syntax) where + tags = runTagging + +instance ToTags Python.Term where + tags _ _ = Precise.tags doParse @@ -102,26 +108,23 @@ doParse , Member Parse sig , Member (Reader PerLanguageModes) sig ) - => (forall t . Precise.ToTags t => t Loc -> m a) - -> [Text] + => (forall t . ToTags t => t Loc -> m a) -> Blob -> m a -doParse with symbolsToSummarize blob = do +doParse with blob = do modes <- ask @PerLanguageModes case blobLanguage blob of - Go -> parse Parser.goParser blob >>= with . mkTerm - Haskell -> parse Parser.haskellParser blob >>= with . mkTerm - JavaScript -> parse Parser.tsxParser blob >>= with . mkTerm - JSON -> parse Parser.jsonParser blob >>= with . mkTerm - JSX -> parse Parser.tsxParser blob >>= with . mkTerm - Markdown -> parse Parser.markdownParser blob >>= with . mkTerm + Go -> parse Parser.goParser blob >>= with + Haskell -> parse Parser.haskellParser blob >>= with + JavaScript -> parse Parser.tsxParser blob >>= with + JSON -> parse Parser.jsonParser blob >>= with + JSX -> parse Parser.tsxParser blob >>= with + Markdown -> parse Parser.markdownParser blob >>= with Python | Precise <- pythonMode modes -> parse Parser.precisePythonParser blob >>= with - | otherwise -> parse Parser.pythonParser blob >>= with . mkTerm - Ruby -> parse Parser.rubyParser blob >>= with . mkTerm - TypeScript -> parse Parser.typescriptParser blob >>= with . mkTerm - TSX -> parse Parser.tsxParser blob >>= with . mkTerm - PHP -> parse Parser.phpParser blob >>= with . mkTerm + | otherwise -> parse Parser.pythonParser blob >>= with + Ruby -> parse Parser.rubyParser blob >>= with + TypeScript -> parse Parser.typescriptParser blob >>= with + TSX -> parse Parser.tsxParser blob >>= with + PHP -> parse Parser.phpParser blob >>= with _ -> noLanguageForBlob (blobPath blob) - where mkTerm :: Term syntax Loc -> ALaCarteTerm syntax Loc - mkTerm = ALaCarteTerm (blobLanguage blob) symbolsToSummarize From f07c8a0c986a6071fcbceda85a49bf491a3b5c12 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:05:02 -0400 Subject: [PATCH 29/94] Use parseWith to produce tags. --- src/Semantic/Api/Symbols.hs | 32 ++++---------------------------- 1 file changed, 4 insertions(+), 28 deletions(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index cc94f5009..dcfc8d64f 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -36,7 +36,7 @@ legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs where go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File] - go blob@Blob{..} = doParse (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile)) + go blob@Blob{..} = asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = tagsToFile [] @@ -66,7 +66,7 @@ parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go where go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File - go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) blob + go blob@Blob{..} = catching $ asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob where catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e)) blobLanguage' = blobLanguage blob @@ -102,29 +102,5 @@ instance ToTags Python.Term where tags _ _ = Precise.tags -doParse - :: ( Carrier sig m - , Member (Error SomeException) sig - , Member Parse sig - , Member (Reader PerLanguageModes) sig - ) - => (forall t . ToTags t => t Loc -> m a) - -> Blob - -> m a -doParse with blob = do - modes <- ask @PerLanguageModes - case blobLanguage blob of - Go -> parse Parser.goParser blob >>= with - Haskell -> parse Parser.haskellParser blob >>= with - JavaScript -> parse Parser.tsxParser blob >>= with - JSON -> parse Parser.jsonParser blob >>= with - JSX -> parse Parser.tsxParser blob >>= with - Markdown -> parse Parser.markdownParser blob >>= with - Python - | Precise <- pythonMode modes -> parse Parser.precisePythonParser blob >>= with - | otherwise -> parse Parser.pythonParser blob >>= with - Ruby -> parse Parser.rubyParser blob >>= with - TypeScript -> parse Parser.typescriptParser blob >>= with - TSX -> parse Parser.tsxParser blob >>= with - PHP -> parse Parser.phpParser blob >>= with - _ -> noLanguageForBlob (blobPath blob) +toTagsParsers :: PerLanguageModes -> [(Language, Parser.SomeParser ToTags Loc)] +toTagsParsers = Parser.allParsers From e8279b90812451fae59b5889b23b80ed76d5b4de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:11:20 -0400 Subject: [PATCH 30/94] Define an action to parse BlobPairs with a single parser. --- src/Control/Effect/Parse.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index d5832b381..7f5a60c25 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -4,13 +4,16 @@ module Control.Effect.Parse Parse(..) , parse , parseWith +, parsePairWith ) where import Control.Effect.Carrier import Control.Effect.Error import Control.Exception (SomeException) +import Data.Bifunctor.Join import Data.Blob import Data.Language +import Data.These import Parsing.Parser data Parse m k @@ -42,3 +45,13 @@ parseWith parseWith parsers with blob = case lookup (blobLanguage blob) parsers of Just (SomeParser parser) -> parse parser blob >>= with _ -> noLanguageForBlob (blobPath blob) + +parsePairWith + :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) + => [(Language, SomeParser c ann)] + -> (forall term . c term => Join These (term ann) -> m a) + -> BlobPair + -> m a +parsePairWith parsers with blobPair = case lookup (languageForBlobPair blobPair) parsers of + Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with + _ -> noLanguageForBlob (pathForBlobPair blobPair) From 4c4329f295a384951907671f9cf900a97c3e7724 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 2 Oct 2019 12:12:05 -0400 Subject: [PATCH 31/94] Use Exception.try and throw to handle errors from tree-sitter FFI. The crossing into IO and across the FFI boundary is a dangerous journey. A `try` call handles all possible dynamic/IO-bound exceptions, and enables the use of a more precise error type on our end (rather than `String`) and makes downstream code simpler (we just pass on the thrown `SomeException` rather than throwing a new one based on a `Left String`). --- src/Control/Carrier/Parse/Measured.hs | 4 ++-- src/Control/Carrier/Parse/Simple.hs | 4 ++-- src/Parsing/TreeSitter.hs | 33 +++++++++++++++++++-------- 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index fddbd3d30..3970d4c82 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -60,13 +60,13 @@ runParser blob@Blob{..} parser = case parser of time "parse.tree_sitter_ast_parse" languageTag $ do config <- asks config parseToAST (configTreeSitterParseTimeout config) language blob - >>= either (trace >=> const (throwError (SomeException ParserTimedOut))) pure + >>= either (\e -> trace (displayException e) *> throwError e) 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 + >>= either (\e -> trace (displayException e) *> throwError e) pure AssignmentParser parser assignment -> runAssignment Assignment.assign parser blob assignment DeterministicParser parser assignment -> runAssignment Deterministic.assign parser blob assignment diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index d7bf004dc..cda892ae7 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -51,11 +51,11 @@ runParser runParser timeout blob@Blob{..} parser = case parser of ASTParser language -> parseToAST timeout language blob - >>= either (throwError . SomeException . ParseFailure) pure + >>= either throwError pure UnmarshalParser language -> parseToPreciseAST timeout language blob - >>= either (throwError . SomeException . ParseFailure) pure + >>= either throwError pure AssignmentParser parser assignment -> runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign blobSource assignment diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 5538db987..04eaeb041 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE DataKinds, GADTs, LambdaCase, ScopedTypeVariables, TypeOperators #-} module Parsing.TreeSitter ( Duration(..) , parseToAST @@ -10,6 +10,7 @@ import Prologue import Control.Effect.Fail import Control.Effect.Lift import Control.Effect.Reader +import qualified Control.Exception import Foreign import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Array (allocaArray) @@ -38,8 +39,8 @@ parseToAST :: ( Bounded grammar => Duration -> Ptr TS.Language -> Blob - -> m (Either String (AST [] grammar)) -parseToAST parseTimeout language blob = runParse parseTimeout language blob (fmap Right . anaM toAST <=< peek) + -> m (Either SomeException (AST [] grammar)) +parseToAST parseTimeout language blob = runParse parseTimeout language blob (anaM toAST <=< peek) parseToPreciseAST :: ( MonadIO m @@ -48,20 +49,34 @@ parseToPreciseAST => Duration -> Ptr TS.Language -> Blob - -> m (Either String (t Loc)) + -> m (Either SomeException (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)))) + >>= either (Control.Exception.throw . UnmarshalFailure) pure + + +data TSParseException + = ParserTimedOut + | IncompatibleVersions + | UnmarshalFailure String + deriving (Eq, Show, Generic) + +instance Exception TSParseException where + displayException = \case + ParserTimedOut -> "tree-sitter: parser timed out" + IncompatibleVersions -> "tree-sitter: incompatible versions" + UnmarshalFailure s -> "tree-sitter: unmarshal failure - " <> show s runParse :: MonadIO m => Duration -> Ptr TS.Language -> Blob - -> (Ptr TS.Node -> IO (Either String a)) - -> m (Either String a) + -> (Ptr TS.Node -> IO a) + -> m (Either SomeException a) runParse parseTimeout language Blob{..} action = - liftIO . TS.withParser language $ \ parser -> do + liftIO . Control.Exception.try . 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) @@ -69,11 +84,11 @@ runParse parseTimeout language Blob{..} action = if compatible then TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do if treePtr == nullPtr then - pure (Left "tree-sitter: null root node") + Control.Exception.throw ParserTimedOut else TS.withRootNode treePtr action else - pure (Left "tree-sitter: incompatible versions") + Control.Exception.throw IncompatibleVersions toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) toAST node@TS.Node{..} = do From bbf3554bd7d30d04424a7c3d0c85881707d54606 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 2 Oct 2019 12:23:59 -0400 Subject: [PATCH 32/94] Move and export the exception type. --- src/Parsing/TreeSitter.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 04eaeb041..f66697ee0 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, GADTs, LambdaCase, ScopedTypeVariables, TypeOperators #-} module Parsing.TreeSitter -( Duration(..) +( TSParseException (..) +, Duration(..) , parseToAST , parseToPreciseAST ) where @@ -30,6 +31,12 @@ import qualified TreeSitter.Parser as TS import qualified TreeSitter.Tree as TS import qualified TreeSitter.Unmarshal as TS +data TSParseException + = ParserTimedOut + | IncompatibleVersions + | UnmarshalFailure String + deriving (Eq, Show, Generic) + -- | Parse a 'Blob' with the given 'TS.Language' and return its AST. -- Returns 'Nothing' if the operation timed out. parseToAST :: ( Bounded grammar @@ -55,13 +62,6 @@ parseToPreciseAST parseTimeout language blob = runParse parseTimeout language bl runM (runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode)))) >>= either (Control.Exception.throw . UnmarshalFailure) pure - -data TSParseException - = ParserTimedOut - | IncompatibleVersions - | UnmarshalFailure String - deriving (Eq, Show, Generic) - instance Exception TSParseException where displayException = \case ParserTimedOut -> "tree-sitter: parser timed out" From 678d586ec52dcd25e5d3ffa1ef8c1d260ca899e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:32:07 -0400 Subject: [PATCH 33/94] Define a HasDiffFor class with a type family for the diff. --- src/Diffing/Interpreter.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 0359952da..f16a07923 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms +, HasDiffFor(..) , DiffTerms(..) , stripDiff ) where @@ -29,10 +30,16 @@ stripDiff :: Functor syntax -> Diff.Diff syntax ann1 ann2 stripDiff = bimap snd snd +class HasDiffFor (term :: * -> *) where + type DiffFor term = (res :: * -> * -> *) | res -> term + class DiffTerms term diff | diff -> term, term -> diff where -- | Diff a 'These' of terms. diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2 +instance HasDiffFor (Term syntax) where + type DiffFor (Term syntax) = Diff.Diff syntax + instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where diffTermPair = these Diff.deleting Diff.inserting diffTerms From 8418813e5b98db0899a6368ee69a1e26e609fd3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:32:47 -0400 Subject: [PATCH 34/94] Define all of the diffing actions using HasDiffFor. --- src/Diffing/Interpreter.hs | 8 ++-- src/Semantic/Api/Diffs.hs | 77 +++++++++++++++++++------------------- 2 files changed, 42 insertions(+), 43 deletions(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index f16a07923..8b8ec68a3 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms , HasDiffFor(..) @@ -33,14 +33,14 @@ stripDiff = bimap snd snd class HasDiffFor (term :: * -> *) where type DiffFor term = (res :: * -> * -> *) | res -> term -class DiffTerms term diff | diff -> term, term -> diff where +class HasDiffFor term => DiffTerms term where -- | Diff a 'These' of terms. - diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2 + diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2 instance HasDiffFor (Term syntax) where type DiffFor (Term syntax) = Diff.Diff syntax -instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where +instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where diffTermPair = these Diff.deleting Diff.inserting diffTerms diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 5eb41b112..272f55026 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ConstraintKinds, FunctionalDependencies, LambdaCase, RankNTypes #-} +{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, RankNTypes #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) @@ -24,14 +24,13 @@ import Control.Lens import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder -import Data.Diff import Data.Graph import Data.JSON.Fields import Data.Language import Data.Term import qualified Data.Text as T import qualified Data.Vector as V -import Diffing.Interpreter (DiffTerms(..)) +import Diffing.Interpreter (HasDiffFor(..), DiffTerms(..)) import Parsing.Parser import Prologue import Rendering.Graph @@ -81,20 +80,20 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor 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 Decorate a b = forall term diff . DiffActions term diff => Blob -> term a -> term b +type Decorate a b = forall term . DiffActions term => Blob -> term a -> term b -class DOTGraphDiff diff where - dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder +class HasDiffFor term => DOTGraphDiff term where + dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Diff syntax) where +instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Term syntax) where dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph -class JSONGraphDiff diff where - jsonGraphDiff :: BlobPair -> diff Loc Loc -> DiffTreeFileGraph +class HasDiffFor term => JSONGraphDiff term where + jsonGraphDiff :: BlobPair -> DiffFor term Loc Loc -> DiffTreeFileGraph -instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Diff syntax) where +instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Term syntax) where jsonGraphDiff blobPair diff = let graph = renderTreeGraph diff toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b) @@ -103,41 +102,41 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphD lang = bridging # languageForBlobPair blobPair -class JSONTreeDiff diff where - jsonTreeDiff :: BlobPair -> diff Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON +class HasDiffFor term => JSONTreeDiff term where + jsonTreeDiff :: BlobPair -> DiffFor term Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON -instance ToJSONFields1 syntax => JSONTreeDiff (Diff syntax) where +instance ToJSONFields1 syntax => JSONTreeDiff (Term syntax) where jsonTreeDiff = renderJSONDiff -class SExprDiff diff where - sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder +class HasDiffFor term => SExprDiff term where + sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Diff syntax) where +instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Term syntax) where sexprDiff = serialize (SExpression ByConstructorName) -class ShowDiff diff where - showDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder +class HasDiffFor term => ShowDiff term where + showDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance Show1 syntax => ShowDiff (Diff syntax) where +instance Show1 syntax => ShowDiff (Term syntax) where showDiff = serialize Show -class LegacySummarizeDiff term diff | diff -> term, term -> diff where +class HasDiffFor term => LegacySummarizeDiff term where legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration) - legacySummarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> Summaries + legacySummarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> Summaries -instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) (Diff syntax) where +instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) where legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra legacySummarizeDiff = renderToCDiff -class SummarizeDiff term diff | diff -> term, term -> diff where +class HasDiffFor term => SummarizeDiff term where decorateTerm :: Blob -> term Loc -> term (Maybe Declaration) - summarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile + summarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile -instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) (Diff syntax) where +instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) where decorateTerm = decoratorWithAlgebra . declarationAlgebra summarizeDiff blobPair diff = foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff) where @@ -157,22 +156,22 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) -type DiffActions term diff = - ( Bifoldable diff - , DiffTerms term diff - , DOTGraphDiff diff - , JSONGraphDiff diff - , JSONTreeDiff diff - , SExprDiff diff - , ShowDiff diff - , LegacySummarizeDiff term diff - , SummarizeDiff term diff +type DiffActions term = + ( Bifoldable (DiffFor term) + , DiffTerms term + , DOTGraphDiff term + , JSONGraphDiff term + , JSONTreeDiff term + , SExprDiff term + , ShowDiff term + , LegacySummarizeDiff term + , SummarizeDiff term ) doDiff :: DiffEffects sig m => Decorate Loc ann - -> (forall term diff . DiffActions term diff => diff ann ann -> m output) + -> (forall term . DiffActions term => DiffFor term ann ann -> m output) -> BlobPair -> m output doDiff decorate render blobPair = do @@ -180,8 +179,8 @@ doDiff decorate render blobPair = do diff <- diffTerms blobPair terms render diff -diffTerms :: (DiffActions term diff, Member Telemetry sig, Carrier sig m, MonadIO m) - => BlobPair -> Join These (term ann) -> m (diff ann ann) +diffTerms :: (DiffActions term, Member Telemetry sig, Carrier sig m, MonadIO m) + => BlobPair -> Join These (term ann) -> m (DiffFor term ann ann) diffTerms blobs terms = time "diff" languageTag $ do let diff = diffTermPair (runJoin terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) @@ -204,4 +203,4 @@ doParse blobPair decorate = case languageForBlobPair blobPair of _ -> noLanguageForBlob (pathForBlobPair blobPair) data SomeTermPair ann where - SomeTermPair :: DiffActions term diff => Join These (term ann) -> SomeTermPair ann + SomeTermPair :: DiffActions term => Join These (term ann) -> SomeTermPair ann From e8a89bfddc219c4e40a92ab6b468bbd793cc3154 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:38:01 -0400 Subject: [PATCH 35/94] Use a class for diff actions. --- src/Semantic/Api/Diffs.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 272f55026..3afe91aed 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, RankNTypes #-} +{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, RankNTypes, UndecidableInstances #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) @@ -156,7 +156,7 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) -type DiffActions term = +class ( Bifoldable (DiffFor term) , DiffTerms term , DOTGraphDiff term @@ -166,7 +166,18 @@ type DiffActions term = , ShowDiff term , LegacySummarizeDiff term , SummarizeDiff term - ) + ) => DiffActions term +instance + ( Bifoldable (DiffFor term) + , DiffTerms term + , DOTGraphDiff term + , JSONGraphDiff term + , JSONTreeDiff term + , SExprDiff term + , ShowDiff term + , LegacySummarizeDiff term + , SummarizeDiff term + ) => DiffActions term doDiff :: DiffEffects sig m From 2c9349087cf1b1ce3ff060dadf95df7868781b72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 12:38:14 -0400 Subject: [PATCH 36/94] Construct the canonical list of diff parsers. --- src/Semantic/Api/Diffs.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 3afe91aed..5a0291b46 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -215,3 +215,7 @@ doParse blobPair decorate = case languageForBlobPair blobPair of data SomeTermPair ann where SomeTermPair :: DiffActions term => Join These (term ann) -> SomeTermPair ann + + +diffParsers :: [(Language, SomeParser DiffActions Loc)] +diffParsers = aLaCarteParsers From 4d2fd76b2da37ffc511c0a7f2efc05e5459b7870 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:03:59 -0400 Subject: [PATCH 37/94] Bifoldable (DiffFor term) is a superclass of DiffTerms. --- src/Diffing/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 8b8ec68a3..d2330724e 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -33,7 +33,7 @@ stripDiff = bimap snd snd class HasDiffFor (term :: * -> *) where type DiffFor term = (res :: * -> * -> *) | res -> term -class HasDiffFor term => DiffTerms term where +class (Bifoldable (DiffFor term), HasDiffFor term) => DiffTerms term where -- | Diff a 'These' of terms. diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2 From a888d6722e707bad9fa9101d4eab4fa0ec851064 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:04:46 -0400 Subject: [PATCH 38/94] Generalize diffTerms to require only DiffTerms. --- src/Semantic/Api/Diffs.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 5a0291b46..40a426022 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -157,8 +157,7 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi class - ( Bifoldable (DiffFor term) - , DiffTerms term + ( DiffTerms term , DOTGraphDiff term , JSONGraphDiff term , JSONTreeDiff term @@ -168,8 +167,7 @@ class , SummarizeDiff term ) => DiffActions term instance - ( Bifoldable (DiffFor term) - , DiffTerms term + ( DiffTerms term , DOTGraphDiff term , JSONGraphDiff term , JSONTreeDiff term @@ -190,7 +188,7 @@ doDiff decorate render blobPair = do diff <- diffTerms blobPair terms render diff -diffTerms :: (DiffActions term, Member Telemetry sig, Carrier sig m, MonadIO m) +diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (term ann) -> m (DiffFor term ann ann) diffTerms blobs terms = time "diff" languageTag $ do let diff = diffTermPair (runJoin terms) From 052c99ec12576477cbb422dc5e16d5f0af4a1a22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:14:25 -0400 Subject: [PATCH 39/94] Define a typeclass for joining constraints together. --- src/Semantic/Api/Diffs.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 40a426022..8831df4e2 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, RankNTypes, UndecidableInstances #-} +{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) @@ -26,6 +26,7 @@ import Data.Blob import Data.ByteString.Builder import Data.Graph import Data.JSON.Fields +import Data.Kind (Constraint) import Data.Language import Data.Term import qualified Data.Text as T @@ -188,6 +189,12 @@ doDiff decorate render blobPair = do diff <- diffTerms blobPair terms render diff +class (c1 term, c2 term) => ((c1 :: (* -> *) -> Constraint) & (c2 :: (* -> *) -> Constraint)) (term :: * -> *) + +infixl 9 & + +instance (c1 term, c2 term) => (c1 & c2) term + diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (term ann) -> m (DiffFor term ann ann) diffTerms blobs terms = time "diff" languageTag $ do From 4036affcf2dfb5568028baea4f086a978f43dd43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:15:07 -0400 Subject: [PATCH 40/94] Define a helper to run a diff with a specific set of parsers. --- src/Semantic/Api/Diffs.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 8831df4e2..37171d913 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ConstraintKinds, LambdaCase, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} +{-# LANGUAGE AllowAmbiguousTypes, GADTs, ConstraintKinds, LambdaCase, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) @@ -195,6 +195,17 @@ infixl 9 & instance (c1 term, c2 term) => (c1 & c2) term +diffWith + :: DiffEffects sig m + => [(Language, SomeParser (DiffTerms & c) Loc)] + -> (forall term . c term => Blob -> term Loc -> term ann) + -> (forall term . c term => DiffFor term ann ann -> m output) + -> BlobPair + -> m output +diffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . Join . bimap (decorate blobL) (decorate blobR) . runJoin) blobPair where + (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair) + errorBlob = Prelude.error "evaluating blob on absent side" + diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (term ann) -> m (DiffFor term ann ann) diffTerms blobs terms = time "diff" languageTag $ do From 589a567e60dfafdaa5eb9237294ee49d94d8da7c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:17:49 -0400 Subject: [PATCH 41/94] Export diffWith. --- src/Semantic/Api/Diffs.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 37171d913..0643884ef 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -5,6 +5,7 @@ module Semantic.Api.Diffs , diffGraph , doDiff + , diffWith , DiffEffects , SomeTermPair(..) From cf37d082d18d836ef27c32d40cdff4b539bf2a29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:18:02 -0400 Subject: [PATCH 42/94] Define sets of parsers for each diff output format. --- src/Semantic/Api/Diffs.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 0643884ef..5d5de2c48 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -10,7 +10,9 @@ module Semantic.Api.Diffs , SomeTermPair(..) + , legacySummarizeDiffParsers , LegacySummarizeDiff(..) + , summarizeDiffParsers , SummarizeDiff(..) ) where @@ -85,6 +87,9 @@ type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Confi type Decorate a b = forall term . DiffActions term => Blob -> term a -> term b +dotGraphDiffParsers :: [(Language, SomeParser DOTGraphDiff Loc)] +dotGraphDiffParsers = aLaCarteParsers + class HasDiffFor term => DOTGraphDiff term where dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder @@ -92,6 +97,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDi dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph +jsonGraphDiffParsers :: [(Language, SomeParser JSONGraphDiff Loc)] +jsonGraphDiffParsers = aLaCarteParsers + class HasDiffFor term => JSONGraphDiff term where jsonGraphDiff :: BlobPair -> DiffFor term Loc Loc -> DiffTreeFileGraph @@ -104,6 +112,9 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphD lang = bridging # languageForBlobPair blobPair +jsonTreeDiffParsers :: [(Language, SomeParser JSONTreeDiff Loc)] +jsonTreeDiffParsers = aLaCarteParsers + class HasDiffFor term => JSONTreeDiff term where jsonTreeDiff :: BlobPair -> DiffFor term Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON @@ -111,6 +122,9 @@ instance ToJSONFields1 syntax => JSONTreeDiff (Term syntax) where jsonTreeDiff = renderJSONDiff +sexprDiffParsers :: [(Language, SomeParser SExprDiff Loc)] +sexprDiffParsers = aLaCarteParsers + class HasDiffFor term => SExprDiff term where sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder @@ -118,6 +132,9 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff sexprDiff = serialize (SExpression ByConstructorName) +showDiffParsers :: [(Language, SomeParser ShowDiff Loc)] +showDiffParsers = aLaCarteParsers + class HasDiffFor term => ShowDiff term where showDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder @@ -125,6 +142,9 @@ instance Show1 syntax => ShowDiff (Term syntax) where showDiff = serialize Show +legacySummarizeDiffParsers :: [(Language, SomeParser LegacySummarizeDiff Loc)] +legacySummarizeDiffParsers = aLaCarteParsers + class HasDiffFor term => LegacySummarizeDiff term where legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration) legacySummarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> Summaries @@ -134,6 +154,9 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySumma legacySummarizeDiff = renderToCDiff +summarizeDiffParsers :: [(Language, SomeParser SummarizeDiff Loc)] +summarizeDiffParsers = aLaCarteParsers + class HasDiffFor term => SummarizeDiff term where decorateTerm :: Blob -> term Loc -> term (Maybe Declaration) summarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile From 5cee2da2072172a5d66e57c9f78656d63885e717 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:20:56 -0400 Subject: [PATCH 43/94] Prove DiffTerms for each of the sets of parsers. --- src/Semantic/Api/Diffs.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 5d5de2c48..9577fb091 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -87,7 +87,7 @@ type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Confi type Decorate a b = forall term . DiffActions term => Blob -> term a -> term b -dotGraphDiffParsers :: [(Language, SomeParser DOTGraphDiff Loc)] +dotGraphDiffParsers :: [(Language, SomeParser (DiffTerms & DOTGraphDiff) Loc)] dotGraphDiffParsers = aLaCarteParsers class HasDiffFor term => DOTGraphDiff term where @@ -97,7 +97,7 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDi dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph -jsonGraphDiffParsers :: [(Language, SomeParser JSONGraphDiff Loc)] +jsonGraphDiffParsers :: [(Language, SomeParser (DiffTerms & JSONGraphDiff) Loc)] jsonGraphDiffParsers = aLaCarteParsers class HasDiffFor term => JSONGraphDiff term where @@ -112,7 +112,7 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphD lang = bridging # languageForBlobPair blobPair -jsonTreeDiffParsers :: [(Language, SomeParser JSONTreeDiff Loc)] +jsonTreeDiffParsers :: [(Language, SomeParser (DiffTerms & JSONTreeDiff) Loc)] jsonTreeDiffParsers = aLaCarteParsers class HasDiffFor term => JSONTreeDiff term where @@ -122,7 +122,7 @@ instance ToJSONFields1 syntax => JSONTreeDiff (Term syntax) where jsonTreeDiff = renderJSONDiff -sexprDiffParsers :: [(Language, SomeParser SExprDiff Loc)] +sexprDiffParsers :: [(Language, SomeParser (DiffTerms & SExprDiff) Loc)] sexprDiffParsers = aLaCarteParsers class HasDiffFor term => SExprDiff term where @@ -132,7 +132,7 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff sexprDiff = serialize (SExpression ByConstructorName) -showDiffParsers :: [(Language, SomeParser ShowDiff Loc)] +showDiffParsers :: [(Language, SomeParser (DiffTerms & ShowDiff) Loc)] showDiffParsers = aLaCarteParsers class HasDiffFor term => ShowDiff term where @@ -142,7 +142,7 @@ instance Show1 syntax => ShowDiff (Term syntax) where showDiff = serialize Show -legacySummarizeDiffParsers :: [(Language, SomeParser LegacySummarizeDiff Loc)] +legacySummarizeDiffParsers :: [(Language, SomeParser (DiffTerms & LegacySummarizeDiff) Loc)] legacySummarizeDiffParsers = aLaCarteParsers class HasDiffFor term => LegacySummarizeDiff term where @@ -154,7 +154,7 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySumma legacySummarizeDiff = renderToCDiff -summarizeDiffParsers :: [(Language, SomeParser SummarizeDiff Loc)] +summarizeDiffParsers :: [(Language, SomeParser (DiffTerms & SummarizeDiff) Loc)] summarizeDiffParsers = aLaCarteParsers class HasDiffFor term => SummarizeDiff term where From 85509fa339e9f634fa57e3f9f0a7871a198429ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:21:08 -0400 Subject: [PATCH 44/94] Explicitly list the type parameters for diffWith. --- src/Semantic/Api/Diffs.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 9577fb091..5903188db 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -220,7 +220,8 @@ infixl 9 & instance (c1 term, c2 term) => (c1 & c2) term diffWith - :: DiffEffects sig m + :: forall ann c output m sig + . DiffEffects sig m => [(Language, SomeParser (DiffTerms & c) Loc)] -> (forall term . c term => Blob -> term Loc -> term ann) -> (forall term . c term => DiffFor term ann ann -> m output) From 4f50381c4cde2a07e71483c40541aafc8e205a91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:21:21 -0400 Subject: [PATCH 45/94] Use diffWith to diff s-expressions. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 5903188db..eacec48d8 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -61,7 +61,7 @@ data DiffOutputFormat parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON -parseDiffBuilder DiffSExpression = distributeFoldMap (doDiff (const id) sexprDiff) +parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith @Loc sexprDiffParsers (const id) sexprDiff) parseDiffBuilder DiffShow = distributeFoldMap (doDiff (const id) showDiff) parseDiffBuilder DiffDotGraph = distributeFoldMap (doDiff (const id) dotGraphDiff) From a6466b86a2f94a7eb50e713b26d0a57fd728483f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:22:18 -0400 Subject: [PATCH 46/94] Use diffWith for show. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index eacec48d8..d1342588f 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -62,7 +62,7 @@ parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith @Loc sexprDiffParsers (const id) sexprDiff) -parseDiffBuilder DiffShow = distributeFoldMap (doDiff (const id) showDiff) +parseDiffBuilder DiffShow = distributeFoldMap (diffWith @Loc showDiffParsers (const id) showDiff) parseDiffBuilder DiffDotGraph = distributeFoldMap (doDiff (const id) dotGraphDiff) jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) From e3734e41657a1908f7a096105226399a50b5d1d2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:22:59 -0400 Subject: [PATCH 47/94] Use diffWith for DOT. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index d1342588f..b3928dd38 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -63,7 +63,7 @@ parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Form parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith @Loc sexprDiffParsers (const id) sexprDiff) parseDiffBuilder DiffShow = distributeFoldMap (diffWith @Loc showDiffParsers (const id) showDiff) -parseDiffBuilder DiffDotGraph = distributeFoldMap (doDiff (const id) dotGraphDiff) +parseDiffBuilder DiffDotGraph = distributeFoldMap (diffWith @Loc dotGraphDiffParsers (const id) dotGraphDiff) jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair From e7013d8c90c4d19eafe1e8b6ab148ab83abe9339 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:23:56 -0400 Subject: [PATCH 48/94] Use diffWith for JSON graphs. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index b3928dd38..18c94670c 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -75,7 +75,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 (const id) (pure . jsonGraphDiff blobPair) blobPair + go blobPair = diffWith jsonGraphDiffParsers (const id) (pure . jsonGraphDiff blobPair) blobPair `catchError` \(SomeException e) -> pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where From af17fb489b5f3884dd9511cfdbc14991728427d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:24:26 -0400 Subject: [PATCH 49/94] Use diffWith for JSON trees. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 18c94670c..389263ffa 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -66,7 +66,7 @@ parseDiffBuilder DiffShow = distributeFoldMap (diffWith @Loc showDiffPars parseDiffBuilder DiffDotGraph = distributeFoldMap (diffWith @Loc dotGraphDiffParsers (const id) dotGraphDiff) jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) -jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair +jsonDiff blobPair = diffWith jsonTreeDiffParsers (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) From 2be893baf0b8ad2041e6f7ff3caf5202c252a6d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:24:56 -0400 Subject: [PATCH 50/94] :fire: diffParsers. --- src/Semantic/Api/Diffs.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 389263ffa..861955c71 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -256,7 +256,3 @@ doParse blobPair decorate = case languageForBlobPair blobPair of data SomeTermPair ann where SomeTermPair :: DiffActions term => Join These (term ann) -> SomeTermPair ann - - -diffParsers :: [(Language, SomeParser DiffActions Loc)] -diffParsers = aLaCarteParsers From dd01c894630b60cd53b9125145acc30d640deb0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:25:42 -0400 Subject: [PATCH 51/94] Use diffWith for legacy summaries. --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 9af3fc53a..58336e895 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -23,7 +23,7 @@ legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where go :: DiffEffects sig m => BlobPair -> m Summaries - go blobPair = doDiff legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair + go blobPair = diffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) where path = T.pack $ pathKeyForBlobPair blobPair From 99f9edf65ff67d0ff60445d4b9751804d518b016 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:26:52 -0400 Subject: [PATCH 52/94] Use diffWith for summaries. --- src/Semantic/Api/TOCSummaries.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 58336e895..a44631905 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -34,7 +34,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 decorateTerm (pure . summarizeDiff blobPair) blobPair + go blobPair = diffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair `catchError` \(SomeException e) -> pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing]) where path = T.pack $ pathKeyForBlobPair blobPair From a5307843c6d1bfba7ffceab841b2afc3a0a748f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:28:08 -0400 Subject: [PATCH 53/94] :fire: doDiff. --- src/Semantic/Api/Diffs.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 861955c71..58cabcd07 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -4,7 +4,6 @@ module Semantic.Api.Diffs , DiffOutputFormat(..) , diffGraph - , doDiff , diffWith , DiffEffects @@ -202,16 +201,6 @@ instance , SummarizeDiff term ) => DiffActions term -doDiff - :: DiffEffects sig m - => Decorate Loc ann - -> (forall term . DiffActions term => DiffFor term ann ann -> m output) - -> BlobPair - -> m output -doDiff decorate render blobPair = do - SomeTermPair terms <- doParse blobPair decorate - diff <- diffTerms blobPair terms - render diff class (c1 term, c2 term) => ((c1 :: (* -> *) -> Constraint) & (c2 :: (* -> *) -> Constraint)) (term :: * -> *) From 2fb8a77ef2dd4f4ce240dce28772e970e7e233ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:28:56 -0400 Subject: [PATCH 54/94] :fire: doParse. --- src/Semantic/Api/Diffs.hs | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 58cabcd07..c4ca1b0da 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -227,21 +227,6 @@ diffTerms blobs terms = time "diff" languageTag $ do diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs -doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Carrier sig m) - => BlobPair -> Decorate Loc ann -> m (SomeTermPair ann) -doParse blobPair decorate = case languageForBlobPair blobPair of - 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 ann where SomeTermPair :: DiffActions term => Join These (term ann) -> SomeTermPair ann From fdc0fb6dcc488267654598f7c45d541d3f8f678f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:29:15 -0400 Subject: [PATCH 55/94] :fire: Decorate. --- src/Semantic/Api/Diffs.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index c4ca1b0da..09f21d2e4 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -83,8 +83,6 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor 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 Decorate a b = forall term . DiffActions term => Blob -> term a -> term b - dotGraphDiffParsers :: [(Language, SomeParser (DiffTerms & DOTGraphDiff) Loc)] dotGraphDiffParsers = aLaCarteParsers From f98471a6143165df96f93bb015a58d654fe9ce3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:30:39 -0400 Subject: [PATCH 56/94] :fire: SomeTermPair. --- src/Semantic/Api/Diffs.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 09f21d2e4..cdcd78077 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -7,8 +7,6 @@ module Semantic.Api.Diffs , diffWith , DiffEffects - , SomeTermPair(..) - , legacySummarizeDiffParsers , LegacySummarizeDiff(..) , summarizeDiffParsers @@ -224,7 +222,3 @@ diffTerms blobs terms = time "diff" languageTag $ do let diff = diffTermPair (runJoin terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs - - -data SomeTermPair ann where - SomeTermPair :: DiffActions term => Join These (term ann) -> SomeTermPair ann From 3ec0981e478687823227404692b41760cb92df2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:30:44 -0400 Subject: [PATCH 57/94] :fire: DiffActions. --- src/Semantic/Api/Diffs.hs | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index cdcd78077..6a8f1717f 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -176,28 +176,6 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) -class - ( DiffTerms term - , DOTGraphDiff term - , JSONGraphDiff term - , JSONTreeDiff term - , SExprDiff term - , ShowDiff term - , LegacySummarizeDiff term - , SummarizeDiff term - ) => DiffActions term -instance - ( DiffTerms term - , DOTGraphDiff term - , JSONGraphDiff term - , JSONTreeDiff term - , SExprDiff term - , ShowDiff term - , LegacySummarizeDiff term - , SummarizeDiff term - ) => DiffActions term - - class (c1 term, c2 term) => ((c1 :: (* -> *) -> Constraint) & (c2 :: (* -> *) -> Constraint)) (term :: * -> *) infixl 9 & From 21f36e1161dc43dfa2f0581323564c669cae0743 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:35:32 -0400 Subject: [PATCH 58/94] Weaken from GADTs to MonoLocalBinds. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 6a8f1717f..96a61c041 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, GADTs, ConstraintKinds, LambdaCase, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, LambdaCase, MonoLocalBinds, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) From 6b77558d695f367d52979cdb9820160e6d6e4d6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:42:15 -0400 Subject: [PATCH 59/94] Rename diffWith to decoratingDiffWith. --- src/Semantic/Api/Diffs.hs | 16 ++++++++-------- src/Semantic/Api/TOCSummaries.hs | 4 ++-- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 96a61c041..f230d00fe 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -4,7 +4,7 @@ module Semantic.Api.Diffs , DiffOutputFormat(..) , diffGraph - , diffWith + , decoratingDiffWith , DiffEffects , legacySummarizeDiffParsers @@ -58,12 +58,12 @@ data DiffOutputFormat parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON -parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith @Loc sexprDiffParsers (const id) sexprDiff) -parseDiffBuilder DiffShow = distributeFoldMap (diffWith @Loc showDiffParsers (const id) showDiff) -parseDiffBuilder DiffDotGraph = distributeFoldMap (diffWith @Loc dotGraphDiffParsers (const id) dotGraphDiff) +parseDiffBuilder DiffSExpression = distributeFoldMap (decoratingDiffWith @Loc sexprDiffParsers (const id) sexprDiff) +parseDiffBuilder DiffShow = distributeFoldMap (decoratingDiffWith @Loc showDiffParsers (const id) showDiff) +parseDiffBuilder DiffDotGraph = distributeFoldMap (decoratingDiffWith @Loc dotGraphDiffParsers (const id) dotGraphDiff) jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) -jsonDiff blobPair = diffWith jsonTreeDiffParsers (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair +jsonDiff blobPair = decoratingDiffWith jsonTreeDiffParsers (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) @@ -72,7 +72,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 = diffWith jsonGraphDiffParsers (const id) (pure . jsonGraphDiff blobPair) blobPair + go blobPair = decoratingDiffWith jsonGraphDiffParsers (const id) (pure . jsonGraphDiff blobPair) blobPair `catchError` \(SomeException e) -> pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where @@ -182,7 +182,7 @@ infixl 9 & instance (c1 term, c2 term) => (c1 & c2) term -diffWith +decoratingDiffWith :: forall ann c output m sig . DiffEffects sig m => [(Language, SomeParser (DiffTerms & c) Loc)] @@ -190,7 +190,7 @@ diffWith -> (forall term . c term => DiffFor term ann ann -> m output) -> BlobPair -> m output -diffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . Join . bimap (decorate blobL) (decorate blobR) . runJoin) blobPair where +decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . Join . bimap (decorate blobL) (decorate blobR) . runJoin) blobPair where (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair) errorBlob = Prelude.error "evaluating blob on absent side" diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index a44631905..b56330767 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -23,7 +23,7 @@ legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where go :: DiffEffects sig m => BlobPair -> m Summaries - go blobPair = diffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair + go blobPair = decoratingDiffWith legacySummarizeDiffParsers legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)]) where path = T.pack $ pathKeyForBlobPair blobPair @@ -34,7 +34,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 = diffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair + go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair `catchError` \(SomeException e) -> pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing]) where path = T.pack $ pathKeyForBlobPair blobPair From 56f8f5f6665938e6c558ad904fefe7ecdbf751f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:43:41 -0400 Subject: [PATCH 60/94] Define an analogue of diffWith which does no decoration. --- src/Semantic/Api/Diffs.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index f230d00fe..996e5e099 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -58,12 +58,12 @@ data DiffOutputFormat parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON -parseDiffBuilder DiffSExpression = distributeFoldMap (decoratingDiffWith @Loc sexprDiffParsers (const id) sexprDiff) -parseDiffBuilder DiffShow = distributeFoldMap (decoratingDiffWith @Loc showDiffParsers (const id) showDiff) -parseDiffBuilder DiffDotGraph = distributeFoldMap (decoratingDiffWith @Loc dotGraphDiffParsers (const id) dotGraphDiff) +parseDiffBuilder DiffSExpression = distributeFoldMap (diffWith sexprDiffParsers sexprDiff) +parseDiffBuilder DiffShow = distributeFoldMap (diffWith showDiffParsers showDiff) +parseDiffBuilder DiffDotGraph = distributeFoldMap (diffWith dotGraphDiffParsers dotGraphDiff) jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) -jsonDiff blobPair = decoratingDiffWith jsonTreeDiffParsers (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair +jsonDiff blobPair = diffWith jsonTreeDiffParsers (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) @@ -72,7 +72,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 = decoratingDiffWith jsonGraphDiffParsers (const id) (pure . jsonGraphDiff blobPair) blobPair + go blobPair = diffWith jsonGraphDiffParsers (pure . jsonGraphDiff blobPair) blobPair `catchError` \(SomeException e) -> pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where @@ -182,6 +182,14 @@ infixl 9 & instance (c1 term, c2 term) => (c1 & c2) term +diffWith + :: DiffEffects sig m + => [(Language, SomeParser (DiffTerms & c) Loc)] + -> (forall term . c term => DiffFor term Loc Loc -> m output) + -> BlobPair + -> m output +diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms blobPair) blobPair + decoratingDiffWith :: forall ann c output m sig . DiffEffects sig m From 49fe06d576eee88a36f22651d68554278fbd79a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:51:35 -0400 Subject: [PATCH 61/94] :fire: the & typeclass. --- src/Semantic/Api/Diffs.hs | 60 ++++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 33 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 996e5e099..e4be8cc41 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, LambdaCase, MonoLocalBinds, RankNTypes, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, LambdaCase, MonoLocalBinds, QuantifiedConstraints, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) @@ -26,11 +26,11 @@ import Data.Blob import Data.ByteString.Builder import Data.Graph import Data.JSON.Fields -import Data.Kind (Constraint) import Data.Language import Data.Term import qualified Data.Text as T import qualified Data.Vector as V +import Diffing.Algorithm (Diffable) import Diffing.Interpreter (HasDiffFor(..), DiffTerms(..)) import Parsing.Parser import Prologue @@ -82,23 +82,23 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor 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) -dotGraphDiffParsers :: [(Language, SomeParser (DiffTerms & DOTGraphDiff) Loc)] +dotGraphDiffParsers :: [(Language, SomeParser DOTGraphDiff Loc)] dotGraphDiffParsers = aLaCarteParsers -class HasDiffFor term => DOTGraphDiff term where +class DiffTerms term => DOTGraphDiff term where dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Term syntax) where +instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DOTGraphDiff (Term syntax) where dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph -jsonGraphDiffParsers :: [(Language, SomeParser (DiffTerms & JSONGraphDiff) Loc)] +jsonGraphDiffParsers :: [(Language, SomeParser JSONGraphDiff Loc)] jsonGraphDiffParsers = aLaCarteParsers -class HasDiffFor term => JSONGraphDiff term where +class DiffTerms term => JSONGraphDiff term where jsonGraphDiff :: BlobPair -> DiffFor term Loc Loc -> DiffTreeFileGraph -instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Term syntax) where +instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => JSONGraphDiff (Term syntax) where jsonGraphDiff blobPair diff = let graph = renderTreeGraph diff toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b) @@ -107,56 +107,56 @@ instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphD lang = bridging # languageForBlobPair blobPair -jsonTreeDiffParsers :: [(Language, SomeParser (DiffTerms & JSONTreeDiff) Loc)] +jsonTreeDiffParsers :: [(Language, SomeParser JSONTreeDiff Loc)] jsonTreeDiffParsers = aLaCarteParsers -class HasDiffFor term => JSONTreeDiff term where +class DiffTerms term => JSONTreeDiff term where jsonTreeDiff :: BlobPair -> DiffFor term Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON -instance ToJSONFields1 syntax => JSONTreeDiff (Term syntax) where +instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => JSONTreeDiff (Term syntax) where jsonTreeDiff = renderJSONDiff -sexprDiffParsers :: [(Language, SomeParser (DiffTerms & SExprDiff) Loc)] +sexprDiffParsers :: [(Language, SomeParser SExprDiff Loc)] sexprDiffParsers = aLaCarteParsers -class HasDiffFor term => SExprDiff term where +class DiffTerms term => SExprDiff term where sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Term syntax) where +instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => SExprDiff (Term syntax) where sexprDiff = serialize (SExpression ByConstructorName) -showDiffParsers :: [(Language, SomeParser (DiffTerms & ShowDiff) Loc)] +showDiffParsers :: [(Language, SomeParser ShowDiff Loc)] showDiffParsers = aLaCarteParsers -class HasDiffFor term => ShowDiff term where +class DiffTerms term => ShowDiff term where showDiff :: (Carrier sig m, Member (Reader Config) sig) => DiffFor term Loc Loc -> m Builder -instance Show1 syntax => ShowDiff (Term syntax) where +instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Show1 syntax, Traversable syntax) => ShowDiff (Term syntax) where showDiff = serialize Show -legacySummarizeDiffParsers :: [(Language, SomeParser (DiffTerms & LegacySummarizeDiff) Loc)] +legacySummarizeDiffParsers :: [(Language, SomeParser LegacySummarizeDiff Loc)] legacySummarizeDiffParsers = aLaCarteParsers -class HasDiffFor term => LegacySummarizeDiff term where +class DiffTerms term => LegacySummarizeDiff term where legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration) legacySummarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> Summaries -instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) where +instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => LegacySummarizeDiff (Term syntax) where legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra legacySummarizeDiff = renderToCDiff -summarizeDiffParsers :: [(Language, SomeParser (DiffTerms & SummarizeDiff) Loc)] +summarizeDiffParsers :: [(Language, SomeParser SummarizeDiff Loc)] summarizeDiffParsers = aLaCarteParsers -class HasDiffFor term => SummarizeDiff term where +class DiffTerms term => SummarizeDiff term where decorateTerm :: Blob -> term Loc -> term (Maybe Declaration) summarizeDiff :: BlobPair -> DiffFor term (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile -instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) where +instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where decorateTerm = decoratorWithAlgebra . declarationAlgebra summarizeDiff blobPair diff = foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff) where @@ -176,15 +176,9 @@ instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDi = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) -class (c1 term, c2 term) => ((c1 :: (* -> *) -> Constraint) & (c2 :: (* -> *) -> Constraint)) (term :: * -> *) - -infixl 9 & - -instance (c1 term, c2 term) => (c1 & c2) term - diffWith - :: DiffEffects sig m - => [(Language, SomeParser (DiffTerms & c) Loc)] + :: (forall term . c term => DiffTerms term, DiffEffects sig m) + => [(Language, SomeParser c Loc)] -> (forall term . c term => DiffFor term Loc Loc -> m output) -> BlobPair -> m output @@ -192,8 +186,8 @@ diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms b decoratingDiffWith :: forall ann c output m sig - . DiffEffects sig m - => [(Language, SomeParser (DiffTerms & c) Loc)] + . (forall term . c term => DiffTerms term, DiffEffects sig m) + => [(Language, SomeParser c Loc)] -> (forall term . c term => Blob -> term Loc -> term ann) -> (forall term . c term => DiffFor term ann ann -> m output) -> BlobPair From 4a6da6903dc52396b86d7f38be3bc70384205af9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:53:08 -0400 Subject: [PATCH 62/94] :fire: redundant language extensions. --- src/Semantic/Api/Diffs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index e4be8cc41..b6d49161f 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, LambdaCase, MonoLocalBinds, QuantifiedConstraints, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, LambdaCase, MonoLocalBinds, QuantifiedConstraints, RankNTypes #-} module Semantic.Api.Diffs ( parseDiffBuilder , DiffOutputFormat(..) From ce3fe3fbe75c352759796469bc24e3696722a249 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 13:57:46 -0400 Subject: [PATCH 63/94] Eliminate a few uses of Join. --- src/Control/Effect/Parse.hs | 4 ++-- src/Semantic/Api/Diffs.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index 7f5a60c25..afb01c43a 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -49,9 +49,9 @@ parseWith parsers with blob = case lookup (blobLanguage blob) parsers of parsePairWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => [(Language, SomeParser c ann)] - -> (forall term . c term => Join These (term ann) -> m a) + -> (forall term . c term => These (term ann) (term ann) -> m a) -> BlobPair -> m a parsePairWith parsers with blobPair = case lookup (languageForBlobPair blobPair) parsers of - Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with + Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin _ -> noLanguageForBlob (pathForBlobPair blobPair) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index b6d49161f..1b581b7b6 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -192,13 +192,13 @@ decoratingDiffWith -> (forall term . c term => DiffFor term ann ann -> m output) -> BlobPair -> m output -decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . Join . bimap (decorate blobL) (decorate blobR) . runJoin) blobPair where +decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . bimap (decorate blobL) (decorate blobR)) blobPair where (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair) errorBlob = Prelude.error "evaluating blob on absent side" diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) - => BlobPair -> Join These (term ann) -> m (DiffFor term ann ann) + => BlobPair -> These (term ann) (term ann) -> m (DiffFor term ann ann) diffTerms blobs terms = time "diff" languageTag $ do - let diff = diffTermPair (runJoin terms) + let diff = diffTermPair terms diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs From 66801bf4f6f904adf819f2898ad8e437711aa51b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:05:04 -0400 Subject: [PATCH 64/94] SomeAnalysisParser uses a single constraint. --- src/Parsing/Parser.hs | 24 ++++++++++++------------ src/Semantic/Graph.hs | 5 +++-- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 4ee5f736b..69d1c6ec6 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -81,26 +81,26 @@ import TreeSitter.Unmarshal -- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. -data SomeAnalysisParser typeclasses ann where - SomeAnalysisParser :: ( ApplyAll typeclasses (Sum fs) +data SomeAnalysisParser constraint ann where + SomeAnalysisParser :: ( constraint (Sum fs) , Apply (VertexDeclaration' (Sum fs)) fs , HasPrelude lang ) => Parser (Term (Sum fs) ann) -> Proxy lang - -> SomeAnalysisParser typeclasses ann + -> SomeAnalysisParser constraint ann -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. -someAnalysisParser :: ( ApplyAll typeclasses (Sum Go.Syntax) - , ApplyAll typeclasses (Sum PHP.Syntax) - , ApplyAll typeclasses (Sum Python.Syntax) - , ApplyAll typeclasses (Sum Ruby.Syntax) - , ApplyAll typeclasses (Sum TypeScript.Syntax) - , ApplyAll typeclasses (Sum Haskell.Syntax) +someAnalysisParser :: ( constraint (Sum Go.Syntax) + , constraint (Sum PHP.Syntax) + , constraint (Sum Python.Syntax) + , constraint (Sum Ruby.Syntax) + , constraint (Sum TypeScript.Syntax) + , constraint (Sum Haskell.Syntax) ) - => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. - -> Language -- ^ The 'Language' to select. - -> SomeAnalysisParser typeclasses Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. + => proxy constraint -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. + -> Language -- ^ The 'Language' to select. + -> SomeAnalysisParser constraint Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy @'Go) someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy @'Haskell) someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy @'JavaScript) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3a5915dff..52160498e 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Graph ( runGraph , runCallGraph @@ -71,7 +71,8 @@ import Text.Show.Pretty (ppShow) data GraphType = ImportGraph | CallGraph -type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, AccessControls1, Foldable, Functor, Ord1, Show1 ] +class (Declarations1 syntax, Eq1 syntax, Evaluatable syntax, FreeVariables1 syntax, AccessControls1 syntax, Foldable syntax, Functor syntax, Ord1 syntax, Show1 syntax) => AnalysisClasses syntax +instance (Declarations1 syntax, Eq1 syntax, Evaluatable syntax, FreeVariables1 syntax, AccessControls1 syntax, Foldable syntax, Functor syntax, Ord1 syntax, Show1 syntax) => AnalysisClasses syntax runGraph :: ( Member Distribute sig , Member (Error SomeException) sig From 9c981030b9ffe63d9ca32b7a08ff60114a813ab2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:05:57 -0400 Subject: [PATCH 65/94] :fire: ApplyAll. --- src/Parsing/Parser.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 69d1c6ec6..f9fc10f6f 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Parsing.Parser ( Parser(..) , SomeAnalysisParser(..) , SomeASTParser(..) , someASTParser , someAnalysisParser -, ApplyAll -- * À la carte parsers , goParser , goASTParser @@ -50,7 +49,6 @@ import qualified CMarkGFM import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Graph.ControlFlowVertex (VertexDeclaration') -import Data.Kind import Data.Language import Data.Sum import qualified Data.Syntax as Syntax @@ -131,12 +129,6 @@ data Parser term where MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) --- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question. -type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where - ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax) - ApplyAll '[] syntax = () - - goParser :: Parser Go.Term goParser = AssignmentParser (ASTParser tree_sitter_go) Go.assignment From 1a1cdc9acb4a6a81fc839fe467154a58def6849a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:10:05 -0400 Subject: [PATCH 66/94] :fire: the export of precisePythonParser. --- src/Parsing/Parser.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index f9fc10f6f..c6680f34e 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -20,8 +20,6 @@ module Parsing.Parser , phpParser , phpASTParser , haskellParser - -- * Precise parsers -, precisePythonParser -- * Abstract parsers , SomeParser(..) , goParser' From ecd283ac435d08529ac33c6b30c8288fcf7024c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:10:59 -0400 Subject: [PATCH 67/94] Rename precisePythonParser to pythonParserPrecise. --- src/Parsing/Parser.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index c6680f34e..917eaa16c 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -170,8 +170,8 @@ markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser Markdown.assignment -precisePythonParser :: Parser (Py.Term Loc) -precisePythonParser = UnmarshalParser tree_sitter_python +pythonParserPrecise :: Parser (Py.Term Loc) +pythonParserPrecise = UnmarshalParser tree_sitter_python -- | A parser for producing specialized (tree-sitter) ASTs. @@ -228,12 +228,12 @@ pythonParserALaCarte' :: c (Term (Sum Python.Syntax)) => (Language, SomeParser c pythonParserALaCarte' = (Python, SomeParser pythonParser) pythonParserPrecise' :: c Py.Term => (Language, SomeParser c Loc) -pythonParserPrecise' = (Python, SomeParser precisePythonParser) +pythonParserPrecise' = (Python, SomeParser pythonParserPrecise) pythonParser' :: (c (Term (Sum Python.Syntax)), c Py.Term) => PerLanguageModes -> (Language, SomeParser c Loc) pythonParser' modes = case pythonMode modes of ALaCarte -> (Python, SomeParser pythonParser) - Precise -> (Python, SomeParser precisePythonParser) + Precise -> (Python, SomeParser pythonParserPrecise) rubyParser' :: c (Term (Sum Ruby.Syntax)) => (Language, SomeParser c Loc) rubyParser' = (Ruby, SomeParser rubyParser) From a7c366cde21973483508e08b0d6bd3862c14327c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:45:16 -0400 Subject: [PATCH 68/94] Use Map instead of lists of pairs for the parsers. --- src/Control/Effect/Parse.hs | 9 +++++---- src/Parsing/Parser.hs | 13 +++++++------ src/Semantic/Api/Diffs.hs | 18 +++++++++--------- src/Semantic/Api/Symbols.hs | 2 +- src/Semantic/Api/Terms.hs | 10 +++++----- 5 files changed, 27 insertions(+), 25 deletions(-) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index afb01c43a..443591956 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -13,6 +13,7 @@ import Control.Exception (SomeException) import Data.Bifunctor.Join import Data.Blob import Data.Language +import qualified Data.Map as Map import Data.These import Parsing.Parser @@ -38,20 +39,20 @@ parse parser blob = send (Parse parser blob pure) parseWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => [(Language, SomeParser c ann)] + => Map.Map Language (SomeParser c ann) -> (forall term . c term => term ann -> m a) -> Blob -> m a -parseWith parsers with blob = case lookup (blobLanguage blob) parsers of +parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of Just (SomeParser parser) -> parse parser blob >>= with _ -> noLanguageForBlob (blobPath blob) parsePairWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => [(Language, SomeParser c ann)] + => Map.Map Language (SomeParser c ann) -> (forall term . c term => These (term ann) (term ann) -> m a) -> BlobPair -> m a -parsePairWith parsers with blobPair = case lookup (languageForBlobPair blobPair) parsers of +parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin _ -> noLanguageForBlob (pathForBlobPair blobPair) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 917eaa16c..cc8a633df 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -48,6 +48,7 @@ import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Graph.ControlFlowVertex (VertexDeclaration') import Data.Language +import qualified Data.Map as Map import Data.Sum import qualified Data.Syntax as Syntax import Data.Term @@ -256,8 +257,8 @@ aLaCarteParsers , c (Term (Sum TSX.Syntax)) , c (Term (Sum TypeScript.Syntax)) ) - => [(Language, SomeParser c Loc)] -aLaCarteParsers = + => Map Language (SomeParser c Loc) +aLaCarteParsers = Map.fromList [ goParser' , haskellParser' , javascriptParser' @@ -271,8 +272,8 @@ aLaCarteParsers = , tsxParser' ] -preciseParsers :: c Py.Term => [(Language, SomeParser c Loc)] -preciseParsers = +preciseParsers :: c Py.Term => Map Language (SomeParser c Loc) +preciseParsers = Map.fromList [ pythonParserPrecise' ] @@ -289,8 +290,8 @@ allParsers , c (Term (Sum TypeScript.Syntax)) ) => PerLanguageModes - -> [(Language, SomeParser c Loc)] -allParsers modes = + -> Map Language (SomeParser c Loc) +allParsers modes = Map.fromList [ goParser' , haskellParser' , javascriptParser' diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 1b581b7b6..23c9c63ba 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -82,7 +82,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor 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) -dotGraphDiffParsers :: [(Language, SomeParser DOTGraphDiff Loc)] +dotGraphDiffParsers :: Map Language (SomeParser DOTGraphDiff Loc) dotGraphDiffParsers = aLaCarteParsers class DiffTerms term => DOTGraphDiff term where @@ -92,7 +92,7 @@ instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph -jsonGraphDiffParsers :: [(Language, SomeParser JSONGraphDiff Loc)] +jsonGraphDiffParsers :: Map Language (SomeParser JSONGraphDiff Loc) jsonGraphDiffParsers = aLaCarteParsers class DiffTerms term => JSONGraphDiff term where @@ -107,7 +107,7 @@ instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, lang = bridging # languageForBlobPair blobPair -jsonTreeDiffParsers :: [(Language, SomeParser JSONTreeDiff Loc)] +jsonTreeDiffParsers :: Map Language (SomeParser JSONTreeDiff Loc) jsonTreeDiffParsers = aLaCarteParsers class DiffTerms term => JSONTreeDiff term where @@ -117,7 +117,7 @@ instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, ToJSONFields1 syntax, T jsonTreeDiff = renderJSONDiff -sexprDiffParsers :: [(Language, SomeParser SExprDiff Loc)] +sexprDiffParsers :: Map Language (SomeParser SExprDiff Loc) sexprDiffParsers = aLaCarteParsers class DiffTerms term => SExprDiff term where @@ -127,7 +127,7 @@ instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, sexprDiff = serialize (SExpression ByConstructorName) -showDiffParsers :: [(Language, SomeParser ShowDiff Loc)] +showDiffParsers :: Map Language (SomeParser ShowDiff Loc) showDiffParsers = aLaCarteParsers class DiffTerms term => ShowDiff term where @@ -137,7 +137,7 @@ instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Show1 syntax, Traversab showDiff = serialize Show -legacySummarizeDiffParsers :: [(Language, SomeParser LegacySummarizeDiff Loc)] +legacySummarizeDiffParsers :: Map Language (SomeParser LegacySummarizeDiff Loc) legacySummarizeDiffParsers = aLaCarteParsers class DiffTerms term => LegacySummarizeDiff term where @@ -149,7 +149,7 @@ instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, legacySummarizeDiff = renderToCDiff -summarizeDiffParsers :: [(Language, SomeParser SummarizeDiff Loc)] +summarizeDiffParsers :: Map Language (SomeParser SummarizeDiff Loc) summarizeDiffParsers = aLaCarteParsers class DiffTerms term => SummarizeDiff term where @@ -178,7 +178,7 @@ instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, diffWith :: (forall term . c term => DiffTerms term, DiffEffects sig m) - => [(Language, SomeParser c Loc)] + => Map Language (SomeParser c Loc) -> (forall term . c term => DiffFor term Loc Loc -> m output) -> BlobPair -> m output @@ -187,7 +187,7 @@ diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms b decoratingDiffWith :: forall ann c output m sig . (forall term . c term => DiffTerms term, DiffEffects sig m) - => [(Language, SomeParser c Loc)] + => Map Language (SomeParser c Loc) -> (forall term . c term => Blob -> term Loc -> term ann) -> (forall term . c term => DiffFor term ann ann -> m output) -> BlobPair diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index dcfc8d64f..40ae1ec1b 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -102,5 +102,5 @@ instance ToTags Python.Term where tags _ _ = Precise.tags -toTagsParsers :: PerLanguageModes -> [(Language, Parser.SomeParser ToTags Loc)] +toTagsParsers :: PerLanguageModes -> Map Language (Parser.SomeParser ToTags Loc) toTagsParsers = Parser.allParsers diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 3c75d9ea9..e819bee3f 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -85,7 +85,7 @@ quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m) -showTermParsers :: PerLanguageModes -> [(Language, SomeParser ShowTerm Loc)] +showTermParsers :: PerLanguageModes -> Map Language (SomeParser ShowTerm Loc) showTermParsers = allParsers class ShowTerm term where @@ -98,7 +98,7 @@ instance ShowTerm Py.Term where showTerm = serialize Show . (() <$) . Py.getTerm -sexprTermParsers :: [(Language, SomeParser SExprTerm Loc)] +sexprTermParsers :: Map Language (SomeParser SExprTerm Loc) sexprTermParsers = aLaCarteParsers class SExprTerm term where @@ -108,7 +108,7 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm sexprTerm = serialize (SExpression ByConstructorName) -dotGraphTermParsers :: [(Language, SomeParser DOTGraphTerm Loc)] +dotGraphTermParsers :: Map Language (SomeParser DOTGraphTerm Loc) dotGraphTermParsers = aLaCarteParsers class DOTGraphTerm term where @@ -118,7 +118,7 @@ instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTe dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph -jsonTreeTermParsers :: [(Language, SomeParser JSONTreeTerm Loc)] +jsonTreeTermParsers :: Map Language (SomeParser JSONTreeTerm Loc) jsonTreeTermParsers = aLaCarteParsers class JSONTreeTerm term where @@ -128,7 +128,7 @@ instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where jsonTreeTerm = renderJSONTerm -jsonGraphTermParsers :: [(Language, SomeParser JSONGraphTerm Loc)] +jsonGraphTermParsers :: Map Language (SomeParser JSONGraphTerm Loc) jsonGraphTermParsers = aLaCarteParsers class JSONGraphTerm term where From 2d21661c85ad821e174ca3e83cc314f618f20ed3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:47:11 -0400 Subject: [PATCH 69/94] :memo: parseWith/parsePairWith. --- src/Control/Effect/Parse.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index 443591956..c16bae020 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -37,6 +37,7 @@ parse :: (Member Parse sig, Carrier sig m) parse parser blob = send (Parse parser blob pure) +-- | Parse a 'Blob' with one of the provided parsers, and run an action on the abstracted term. parseWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => Map.Map Language (SomeParser c ann) @@ -47,6 +48,7 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of Just (SomeParser parser) -> parse parser blob >>= with _ -> noLanguageForBlob (blobPath blob) +-- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair. parsePairWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) => Map.Map Language (SomeParser c ann) From fd94a1d3f2a748917cb36c64c1ad95e738c5e485 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:48:36 -0400 Subject: [PATCH 70/94] :memo: the canonical sets of parsers. --- src/Parsing/Parser.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index cc8a633df..4c8838b20 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -246,6 +246,7 @@ typescriptParser' :: c (Term (Sum TypeScript.Syntax)) => (Language, SomeParser c typescriptParser' = (TypeScript, SomeParser typescriptParser) +-- | The canonical set of parsers producing à la carte terms. aLaCarteParsers :: ( c (Term (Sum Go.Syntax)) , c (Term (Sum Haskell.Syntax)) @@ -272,11 +273,13 @@ aLaCarteParsers = Map.fromList , tsxParser' ] +-- | The canonical set of parsers producing precise terms. preciseParsers :: c Py.Term => Map Language (SomeParser c Loc) preciseParsers = Map.fromList [ pythonParserPrecise' ] +-- | The canonical set of all parsers for the passed per-language modes. allParsers :: ( c (Term (Sum Go.Syntax)) , c (Term (Sum Haskell.Syntax)) From 17481f566e9bfc264bd31b4c6198d4e7efb953da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 14:52:45 -0400 Subject: [PATCH 71/94] :memo: SomeParser. --- src/Parsing/Parser.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 4c8838b20..334d3b28b 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -201,6 +201,9 @@ someASTParser Markdown = Nothing someASTParser Unknown = Nothing +-- | A parser producing terms of existentially-quantified type under some constraint @c@. +-- +-- This can be used to perform actions on terms supporting some feature abstracted using a typeclass, without knowing (or caring) what the specific term types are. data SomeParser c a where SomeParser :: c t => Parser (t a) -> SomeParser c a From 80fbd7184fbfdf18a7037edd2fa14196ce7c76bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:05:33 -0400 Subject: [PATCH 72/94] :memo: the abstract parsers. --- src/Parsing/Parser.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 334d3b28b..e9e308b10 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -21,6 +21,8 @@ module Parsing.Parser , phpASTParser , haskellParser -- * Abstract parsers + + -- $abstract , SomeParser(..) , goParser' , haskellParser' @@ -201,6 +203,31 @@ someASTParser Markdown = Nothing someASTParser Unknown = Nothing +-- $abstract +-- Most of our features are intended to operate over multiple languages, each represented by disjoint term types. Thus, we typically implement them using typeclasses, allowing us to share a single interface to invoke the feature, while specializing the implementation(s) as appropriate for each distinct term type. +-- +-- In order to accomplish this, we employ 'SomeParser', which abstracts over parsers of various term types, while ensuring that some desired constraint holds. Constructing a @'SomeParser' c@ requires satisfiyng the constraint @c@ against the underlying 'Parser'’s term type, and so it can be used to parse with any of a map of parsers whose terms support @c@. +-- +-- In practice, this means using 'Control.Effect.Parse.parseWith', and passing in a map of parsers to select from for your feature. It is recommended to define the map as a concrete top-level binding using the abstract parsers or ideally the canonical maps of parsers, below; using the abstracted parsers or canonical maps directly with 'Control.Effect.Parse.parseWith' will lead to significantly slower compiles. +-- +-- Bad: +-- +-- @ +-- isFancy :: (Carrier sig m, Member Parse sig) => Blob -> m Bool +-- isFancy = parseWith (preciseParsers @Fancy) (pure . isTermFancy) -- slow compiles! +-- @ +-- +-- Good: +-- +-- @ +-- fancyParsers :: 'Map' 'Language' ('SomeParser' Fancy 'Loc') +-- fancyParsers = preciseParsers +-- +-- isFancy :: (Carrier sig m, Member Parse sig) => Blob -> m Bool +-- isFancy = parseWith fancyParsers (pure . isTermFancy) -- much faster compiles +-- @ + + -- | A parser producing terms of existentially-quantified type under some constraint @c@. -- -- This can be used to perform actions on terms supporting some feature abstracted using a typeclass, without knowing (or caring) what the specific term types are. From 87e72d1e0e5f6b561dafc7a97ba6e661ba3f8386 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:13:40 -0400 Subject: [PATCH 73/94] Give a kind signature for the constraint parameter to SomeAnalysisParser. --- src/Parsing/Parser.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index e9e308b10..bfba861ca 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Parsing.Parser ( Parser(..) , SomeAnalysisParser(..) @@ -50,6 +50,7 @@ import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Graph.ControlFlowVertex (VertexDeclaration') import Data.Language +import Data.Kind (Constraint) import qualified Data.Map as Map import Data.Sum import qualified Data.Syntax as Syntax @@ -80,7 +81,7 @@ import TreeSitter.Unmarshal -- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. -data SomeAnalysisParser constraint ann where +data SomeAnalysisParser (constraint :: (* -> *) -> Constraint) ann where SomeAnalysisParser :: ( constraint (Sum fs) , Apply (VertexDeclaration' (Sum fs)) fs , HasPrelude lang From 3dd91ec21afa354081946904fdada0b5ed79faac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:13:48 -0400 Subject: [PATCH 74/94] Fix some docs. --- src/Parsing/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index bfba861ca..3bd30d28d 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -98,7 +98,7 @@ someAnalysisParser :: ( constraint (Sum Go.Syntax) , constraint (Sum TypeScript.Syntax) , constraint (Sum Haskell.Syntax) ) - => proxy constraint -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. + => proxy constraint -- ^ A proxy for the constraint required, e.g. @(Proxy \@Show1)@. -> Language -- ^ The 'Language' to select. -> SomeAnalysisParser constraint Loc -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy @'Go) From 7433b7e6b16c0b2d8d215ceb00b615579e41e7f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:16:35 -0400 Subject: [PATCH 75/94] =?UTF-8?q?:memo:=20parseWith=20&=20parsePairWith?= =?UTF-8?q?=E2=80=99s=20parameters.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Effect/Parse.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index c16bae020..07be28411 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -40,9 +40,9 @@ parse parser blob = send (Parse parser blob pure) -- | Parse a 'Blob' with one of the provided parsers, and run an action on the abstracted term. parseWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => Map.Map Language (SomeParser c ann) - -> (forall term . c term => term ann -> m a) - -> Blob + => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. + -> (forall term . c term => term ann -> m a) -- ^ A function to run on the parsed term. Note that the term is abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. + -> Blob -- ^ The blob to parse. -> m a parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of Just (SomeParser parser) -> parse parser blob >>= with @@ -51,9 +51,9 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of -- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair. parsePairWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => Map.Map Language (SomeParser c ann) - -> (forall term . c term => These (term ann) (term ann) -> m a) - -> BlobPair + => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. + -> (forall term . c term => These (term ann) (term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. + -> BlobPair -- ^ The blob pair to parse. -> m a parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin From 843b49b26dc142754359d9f2f413f36c8384167f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:18:13 -0400 Subject: [PATCH 76/94] :fire: HasDiffFor. --- src/Diffing/Interpreter.hs | 8 ++------ src/Semantic/Api/Diffs.hs | 2 +- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index d2330724e..505acaf9b 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,7 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilyDependencies, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms -, HasDiffFor(..) , DiffTerms(..) , stripDiff ) where @@ -30,17 +29,14 @@ stripDiff :: Functor syntax -> Diff.Diff syntax ann1 ann2 stripDiff = bimap snd snd -class HasDiffFor (term :: * -> *) where +class (Bifoldable (DiffFor term)) => DiffTerms term where type DiffFor term = (res :: * -> * -> *) | res -> term -class (Bifoldable (DiffFor term), HasDiffFor term) => DiffTerms term where -- | Diff a 'These' of terms. diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2 -instance HasDiffFor (Term syntax) where - type DiffFor (Term syntax) = Diff.Diff syntax - instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where + type DiffFor (Term syntax) = Diff.Diff syntax diffTermPair = these Diff.deleting Diff.inserting diffTerms diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 23c9c63ba..81f2b234d 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -31,7 +31,7 @@ import Data.Term import qualified Data.Text as T import qualified Data.Vector as V import Diffing.Algorithm (Diffable) -import Diffing.Interpreter (HasDiffFor(..), DiffTerms(..)) +import Diffing.Interpreter (DiffTerms(..)) import Parsing.Parser import Prologue import Rendering.Graph From 8b705faefc53902023d2e5f527f5495e3ce92d2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:18:29 -0400 Subject: [PATCH 77/94] Rename the DiffFor result variable. --- src/Diffing/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 505acaf9b..7d7266da0 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -30,7 +30,7 @@ stripDiff :: Functor syntax stripDiff = bimap snd snd class (Bifoldable (DiffFor term)) => DiffTerms term where - type DiffFor term = (res :: * -> * -> *) | res -> term + type DiffFor term = (diff :: * -> * -> *) | diff -> term -- | Diff a 'These' of terms. diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2 From e4346562d6fba006525e844c8f2c6631558f0a7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:18:48 -0400 Subject: [PATCH 78/94] :memo: DiffTerms. --- src/Diffing/Interpreter.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 7d7266da0..22a5e839b 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -29,6 +29,7 @@ stripDiff :: Functor syntax -> Diff.Diff syntax ann1 ann2 stripDiff = bimap snd snd +-- | The class of term types for which we can compute a diff. class (Bifoldable (DiffFor term)) => DiffTerms term where type DiffFor term = (diff :: * -> * -> *) | diff -> term From 0c3170edc48c5d81f639d5744a5bc5ed49de6859 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:21:13 -0400 Subject: [PATCH 79/94] :memo: DiffFor. --- src/Diffing/Interpreter.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 22a5e839b..f87f72c40 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -31,6 +31,9 @@ stripDiff = bimap snd snd -- | The class of term types for which we can compute a diff. class (Bifoldable (DiffFor term)) => DiffTerms term where + -- | The type of diffs for the given term type. + -- + -- Note that the dependency means that the diff type is in 1:1 correspondence with the term type. This allows subclasses of 'DiffTerms' to receive e.g. @'DiffFor' term a b@ without incurring ambiguity, since every diff type is unique to its term type. type DiffFor term = (diff :: * -> * -> *) | diff -> term -- | Diff a 'These' of terms. From f5f3124efad75ad92d780af3be818900e55a6c60 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:26:15 -0400 Subject: [PATCH 80/94] :memo: diffWith/decoratingDiffWith. --- src/Semantic/Api/Diffs.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 81f2b234d..09996b228 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -176,6 +176,9 @@ instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) +-- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff. +-- +-- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface. diffWith :: (forall term . c term => DiffTerms term, DiffEffects sig m) => Map Language (SomeParser c Loc) @@ -184,6 +187,9 @@ diffWith -> m output diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms blobPair) blobPair +-- | Parse a 'BlobPair' using one of the provided parsers, decorate the resulting terms, diff them, and run an action on the abstracted diff. +-- +-- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface. decoratingDiffWith :: forall ann c output m sig . (forall term . c term => DiffTerms term, DiffEffects sig m) From 34aaec96d75755b887a3291f358de3cafc03cb98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:30:21 -0400 Subject: [PATCH 81/94] :memo: the parameters to diffWith/decoratingDiffWith. --- src/Semantic/Api/Diffs.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 09996b228..3b856e876 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -181,9 +181,9 @@ instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, -- This allows us to define features using an abstract interface, and use them with diffs for any parser whose terms support that interface. diffWith :: (forall term . c term => DiffTerms term, DiffEffects sig m) - => Map Language (SomeParser c Loc) - -> (forall term . c term => DiffFor term Loc Loc -> m output) - -> BlobPair + => Map Language (SomeParser c Loc) -- ^ The set of parsers to select from. + -> (forall term . c term => DiffFor term Loc Loc -> m output) -- ^ A function to run on the computed diff. Note that the diff is abstract (it’s the diff type corresponding to an abstract term type), but the term type is constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. + -> BlobPair -- ^ The blob pair to parse. -> m output diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms blobPair) blobPair @@ -193,10 +193,10 @@ diffWith parsers render blobPair = parsePairWith parsers (render <=< diffTerms b decoratingDiffWith :: forall ann c output m sig . (forall term . c term => DiffTerms term, DiffEffects sig m) - => Map Language (SomeParser c Loc) - -> (forall term . c term => Blob -> term Loc -> term ann) - -> (forall term . c term => DiffFor term ann ann -> m output) - -> BlobPair + => Map Language (SomeParser c Loc) -- ^ The set of parsers to select from. + -> (forall term . c term => Blob -> term Loc -> term ann) -- ^ A function to decorate the terms, replacing their annotations and thus the annotations in the resulting diff. + -> (forall term . c term => DiffFor term ann ann -> m output) -- ^ A function to run on the computed diff. Note that the diff is abstract (it’s the diff type corresponding to an abstract term type), but the term type is constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. + -> BlobPair -- ^ The blob pair to parse. -> m output decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . bimap (decorate blobL) (decorate blobR)) blobPair where (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair) From e0bc6dc9a8c8918b63691f17722d762281628aad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:31:56 -0400 Subject: [PATCH 82/94] Update src/Semantic/Api/Terms.hs Co-Authored-By: Patrick Thomson --- src/Semantic/Api/Terms.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index e819bee3f..6a9811e5e 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -95,7 +95,7 @@ instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where showTerm = serialize Show . quieterm instance ShowTerm Py.Term where - showTerm = serialize Show . (() <$) . Py.getTerm + showTerm = serialize Show . void . Py.getTerm sexprTermParsers :: Map Language (SomeParser SExprTerm Loc) From 898eb8a22d0b27e0dee188b9de5a0846e4fd707c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:34:50 -0400 Subject: [PATCH 83/94] Reformat AnalysisClasses. --- src/Semantic/Graph.hs | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 675b1470b..81dc3b176 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -71,8 +71,28 @@ import Text.Show.Pretty (ppShow) data GraphType = ImportGraph | CallGraph -class (Declarations1 syntax, Eq1 syntax, Evaluatable syntax, FreeVariables1 syntax, AccessControls1 syntax, Foldable syntax, Functor syntax, Ord1 syntax, Show1 syntax) => AnalysisClasses syntax -instance (Declarations1 syntax, Eq1 syntax, Evaluatable syntax, FreeVariables1 syntax, AccessControls1 syntax, Foldable syntax, Functor syntax, Ord1 syntax, Show1 syntax) => AnalysisClasses syntax +class + ( Declarations1 syntax + , Eq1 syntax + , Evaluatable syntax + , FreeVariables1 syntax + , AccessControls1 syntax + , Foldable syntax + , Functor syntax + , Ord1 syntax + , Show1 syntax + ) => AnalysisClasses syntax +instance + ( Declarations1 syntax + , Eq1 syntax + , Evaluatable syntax + , FreeVariables1 syntax + , AccessControls1 syntax + , Foldable syntax + , Functor syntax + , Ord1 syntax + , Show1 syntax + ) => AnalysisClasses syntax runGraph :: ( Member Distribute sig , Member Parse sig From ce8928e9a2c9db0cfc2d4b4a9da95a0bdc26431b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:36:06 -0400 Subject: [PATCH 84/94] :memo: AnalysisClasses. --- src/Semantic/Graph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 81dc3b176..aa92c2f17 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -71,6 +71,7 @@ import Text.Show.Pretty (ppShow) data GraphType = ImportGraph | CallGraph +-- | Constraints we require for a term’s syntax in order to analyze it. class ( Declarations1 syntax , Eq1 syntax From e55426cff19c28c1b8867a2a0d8e37da23027a32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Oct 2019 15:51:40 -0400 Subject: [PATCH 85/94] Weaken the language extension to MonoLocalBinds. --- src/Semantic/Api/Terms.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 6a9811e5e..d1bf5323d 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes #-} +{-# LANGUAGE ConstraintKinds, MonoLocalBinds, RankNTypes #-} module Semantic.Api.Terms ( termGraph , parseTermBuilder From 2231f7e74932768a698bee1966d37e20f7bf872c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 2 Oct 2019 18:42:18 -0400 Subject: [PATCH 86/94] Make runParse return an Either TSParseException. --- src/Control/Carrier/Parse/Measured.hs | 4 ++-- src/Control/Carrier/Parse/Simple.hs | 4 ++-- src/Parsing/TreeSitter.hs | 16 ++++++++-------- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index fa2da6c92..49df96d71 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -60,13 +60,13 @@ runParser blob@Blob{..} parser = case parser of time "parse.tree_sitter_ast_parse" languageTag $ do config <- asks config parseToAST (configTreeSitterParseTimeout config) language blob - >>= either (\e -> trace (displayException e) *> throwError e) pure + >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure UnmarshalParser language -> time "parse.tree_sitter_ast_parse" languageTag $ do config <- asks config parseToPreciseAST (configTreeSitterParseTimeout config) language blob - >>= either (\e -> trace (displayException e) *> throwError e) pure + >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure AssignmentParser parser assignment -> runAssignment Assignment.assign parser blob assignment DeterministicParser parser assignment -> runAssignment Deterministic.assign parser blob assignment diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index 202ce82fe..e9e459f6c 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -51,11 +51,11 @@ runParser runParser timeout blob@Blob{..} parser = case parser of ASTParser language -> parseToAST timeout language blob - >>= either throwError pure + >>= either (throwError . SomeException) pure UnmarshalParser language -> parseToPreciseAST timeout language blob - >>= either throwError pure + >>= either (throwError . SomeException) pure AssignmentParser parser assignment -> runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign blobSource assignment diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index f66697ee0..c3f707ea5 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -11,7 +11,7 @@ import Prologue import Control.Effect.Fail import Control.Effect.Lift import Control.Effect.Reader -import qualified Control.Exception +import qualified Control.Exception as Exc import Foreign import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Array (allocaArray) @@ -46,7 +46,7 @@ parseToAST :: ( Bounded grammar => Duration -> Ptr TS.Language -> Blob - -> m (Either SomeException (AST [] grammar)) + -> m (Either TSParseException (AST [] grammar)) parseToAST parseTimeout language blob = runParse parseTimeout language blob (anaM toAST <=< peek) parseToPreciseAST @@ -56,11 +56,11 @@ parseToPreciseAST => Duration -> Ptr TS.Language -> Blob - -> m (Either SomeException (t Loc)) + -> m (Either TSParseException (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)))) - >>= either (Control.Exception.throw . UnmarshalFailure) pure + >>= either (Exc.throw . UnmarshalFailure) pure instance Exception TSParseException where displayException = \case @@ -74,9 +74,9 @@ runParse -> Ptr TS.Language -> Blob -> (Ptr TS.Node -> IO a) - -> m (Either SomeException a) + -> m (Either TSParseException a) runParse parseTimeout language Blob{..} action = - liftIO . Control.Exception.try . TS.withParser language $ \ parser -> do + liftIO . Exc.tryJust fromException . 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) @@ -84,11 +84,11 @@ runParse parseTimeout language Blob{..} action = if compatible then TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do if treePtr == nullPtr then - Control.Exception.throw ParserTimedOut + Exc.throw ParserTimedOut else TS.withRootNode treePtr action else - Control.Exception.throw IncompatibleVersions + Exc.throw IncompatibleVersions toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) toAST node@TS.Node{..} = do From 5b75abb0723c9050d87dd358d4e6f49056a7add1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:26:44 -0400 Subject: [PATCH 87/94] Loosen the bound on hashable. --- semantic-source/semantic-source.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index 183532d9e..9e5cc492f 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -51,7 +51,7 @@ library , bytestring ^>= 0.10.8.2 , deepseq ^>= 1.4.4.0 , generic-monoid ^>= 0.1.0.0 - , hashable ^>= 1.2.7.0 + , hashable >= 1.2.7 && < 1.4 , semilattices ^>= 0.0.0.3 , text ^>= 1.2.3.1 hs-source-dirs: src From 0c31921bbd2979345c571c5e63410dfac53e5e99 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:29:45 -0400 Subject: [PATCH 88/94] Add 8.8.1 to the tested-with field. --- semantic-source/semantic-source.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index 9e5cc492f..e4cdc55c9 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -20,6 +20,7 @@ extra-source-files: tested-with: GHC == 8.6.5 + GHC == 8.8.1 common common default-language: Haskell2010 From 610133fdce7041e1c403118c3f15942761b72014 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:29:52 -0400 Subject: [PATCH 89/94] Turn off the no missing deriving strategies warning. --- semantic-source/semantic-source.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index e4cdc55c9..a63cedd2b 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -36,6 +36,8 @@ common common -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-star-is-type + if (impl(ghc >= 8.8)) + ghc-options: -Wno-missing-deriving-strategies library import: common From f51eec5752d5bdccd86b135c7dd78715257e13c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:30:09 -0400 Subject: [PATCH 90/94] Add a changelog. --- semantic-source/CHANGELOG.md | 3 +++ semantic-source/semantic-source.cabal | 1 + 2 files changed, 4 insertions(+) create mode 100644 semantic-source/CHANGELOG.md diff --git a/semantic-source/CHANGELOG.md b/semantic-source/CHANGELOG.md new file mode 100644 index 000000000..f9e84de25 --- /dev/null +++ b/semantic-source/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.0.0.0 + +Initial release diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index a63cedd2b..3dec63fd4 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -15,6 +15,7 @@ category: Data build-type: Simple stability: alpha extra-source-files: + CHANGELOG.md README.md From f865da96f5fa2fa7888f2caeeb067a60691da1ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:30:11 -0400 Subject: [PATCH 91/94] Spacing. --- semantic-source/semantic-source.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index 3dec63fd4..5d6687459 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -18,7 +18,6 @@ extra-source-files: CHANGELOG.md README.md - tested-with: GHC == 8.6.5 GHC == 8.8.1 From 5f8288ebfe9c60e018a0b14364149e24b1c48c50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:30:29 -0400 Subject: [PATCH 92/94] Tidy up. --- semantic-source/semantic-source.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index 5d6687459..56f9e1dcd 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -46,8 +46,6 @@ library Source.Range Source.Source Source.Span - -- other-modules: - -- other-extensions: build-depends: aeson ^>= 1.4.2.0 , base >= 4.12 && < 5 From 6918d47e3d1f604f26d62e6194f3e1545fbcab9e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:31:19 -0400 Subject: [PATCH 93/94] Bump the version to 0.0.0.1. --- semantic-source/semantic-source.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic-source/semantic-source.cabal b/semantic-source/semantic-source.cabal index 56f9e1dcd..6e683a3db 100644 --- a/semantic-source/semantic-source.cabal +++ b/semantic-source/semantic-source.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: semantic-source -version: 0.0.0.0 +version: 0.0.0.1 synopsis: Types and functionality for working with source code description: Types and functionality for working with source code (program text). homepage: https://github.com/github/semantic/tree/master/semantic-source#readme From 93746a4737c99c0d8e1942c08909570603053021 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Oct 2019 11:32:09 -0400 Subject: [PATCH 94/94] Add notes to the changelog. --- semantic-source/CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/semantic-source/CHANGELOG.md b/semantic-source/CHANGELOG.md index f9e84de25..50ed229aa 100644 --- a/semantic-source/CHANGELOG.md +++ b/semantic-source/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.0.0.1 + +- Loosens the upper bound on `hashable`. +- Adds support for GHC 8.8.1. + + # 0.0.0.0 Initial release