From 7135cf0727feb27252ae0166fe68c9c489e20cbf Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Jul 2017 12:14:17 -0400 Subject: [PATCH 01/11] Add json project --- .gitmodules | 3 ++ languages/json/Setup.hs | 2 ++ languages/json/json.cabal | 28 +++++++++++++++++++ .../json/src/Text/Parser/TreeSitter/JSON.hs | 6 ++++ languages/json/vendor/tree-sitter-json | 1 + 5 files changed, 40 insertions(+) create mode 100644 languages/json/Setup.hs create mode 100644 languages/json/json.cabal create mode 100644 languages/json/src/Text/Parser/TreeSitter/JSON.hs create mode 160000 languages/json/vendor/tree-sitter-json diff --git a/.gitmodules b/.gitmodules index 410930286..0e9fd3c07 100644 --- a/.gitmodules +++ b/.gitmodules @@ -34,3 +34,6 @@ [submodule "languages/python/vendor/tree-sitter-python"] path = languages/python/vendor/tree-sitter-python url = https://github.com/tree-sitter/tree-sitter-python.git +[submodule "languages/json/vendor/tree-sitter-json"] + path = languages/json/vendor/tree-sitter-json + url = https://github.com/tree-sitter/tree-sitter-json diff --git a/languages/json/Setup.hs b/languages/json/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/languages/json/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/languages/json/json.cabal b/languages/json/json.cabal new file mode 100644 index 000000000..7c21941e2 --- /dev/null +++ b/languages/json/json.cabal @@ -0,0 +1,28 @@ +name: json +version: 0.1.0 +synopsis: tree-sitter json language bindings +description: Please see README.md +homepage: https://github.com/github/semantic-diff#readme +author: semantic-code +maintainer: vera@github.com +copyright: 2017 GitHub +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Text.Parser.TreeSitter.JSON + build-depends: base >= 4.7 && < 5 + , haskell-tree-sitter + default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards + c-sources: vendor/tree-sitter-json/src/parser.c + , vendor/tree-sitter-json/src/scanner.c + cc-options: -std=c99 -Os + + +source-repository head + type: git + location: https://github.com/github/semantic-diff diff --git a/languages/json/src/Text/Parser/TreeSitter/JSON.hs b/languages/json/src/Text/Parser/TreeSitter/JSON.hs new file mode 100644 index 000000000..92dec946e --- /dev/null +++ b/languages/json/src/Text/Parser/TreeSitter/JSON.hs @@ -0,0 +1,6 @@ +module Text.Parser.TreeSitter.JSON where + +import Foreign.Ptr +import Text.Parser.TreeSitter + +foreign import ccall unsafe "vendor/tree-sitter-json/src/parser.c tree_sitter_json" tree_sitter_json :: Ptr Language diff --git a/languages/json/vendor/tree-sitter-json b/languages/json/vendor/tree-sitter-json new file mode 160000 index 000000000..5c21eb644 --- /dev/null +++ b/languages/json/vendor/tree-sitter-json @@ -0,0 +1 @@ +Subproject commit 5c21eb6446ca3e0a49fe710fb948d8efb8a5b6da From 7078fb84f89d0a57032b4a08b88a4edee63def1f Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Jul 2017 12:34:14 -0400 Subject: [PATCH 02/11] Add json package dep --- semantic-diff.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 948522829..3ef33fd5f 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -118,6 +118,7 @@ library , ruby , typescript , python + , json default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, StrictData ghc-options: -Wall -fno-warn-name-shadowing -O -j From 3f6c71b3a4b975d894bbb7833729350326e98de3 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Jul 2017 12:52:50 -0400 Subject: [PATCH 03/11] Add json grammar module --- languages/json/json.cabal | 1 - semantic-diff.cabal | 1 + src/Language.hs | 2 ++ src/Language/JSON/Grammar.hs | 10 ++++++++++ src/Parser.hs | 2 ++ 5 files changed, 15 insertions(+), 1 deletion(-) create mode 100644 src/Language/JSON/Grammar.hs diff --git a/languages/json/json.cabal b/languages/json/json.cabal index 7c21941e2..0b8e025c3 100644 --- a/languages/json/json.cabal +++ b/languages/json/json.cabal @@ -19,7 +19,6 @@ library default-language: Haskell2010 default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-json/src/parser.c - , vendor/tree-sitter-json/src/scanner.c cc-options: -std=c99 -Os diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 3ef33fd5f..ae8c8abad 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -51,6 +51,7 @@ library , Language.Markdown.Syntax , Language.Go , Language.Go.Syntax + , Language.JSON.Grammar , Language.Ruby , Language.Ruby.Grammar , Language.Ruby.Syntax diff --git a/src/Language.hs b/src/Language.hs index f86897322..a70fb9480 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -14,6 +14,7 @@ data Language = C | Go | JavaScript + | JSON | Markdown | Python | Ruby @@ -25,6 +26,7 @@ languageForType :: String -> Maybe Language languageForType mediaType = case mediaType of ".h" -> Just C ".c" -> Just C + ".json" -> Just JSON ".md" -> Just Markdown ".rb" -> Just Ruby ".go" -> Just Language.Go diff --git a/src/Language/JSON/Grammar.hs b/src/Language/JSON/Grammar.hs new file mode 100644 index 000000000..2439fe472 --- /dev/null +++ b/src/Language/JSON/Grammar.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.JSON.Grammar where + +import Language.Haskell.TH +import Text.Parser.TreeSitter.Language +import Text.Parser.TreeSitter.JSON + +-- | Statically-known rules corresponding to symbols in the grammar. +-- v1 - bump this to regenerate +mkSymbolDatatype (mkName "Grammar") tree_sitter_json diff --git a/src/Parser.hs b/src/Parser.hs index 22e8c1654..c469ebafa 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -33,6 +33,7 @@ import Text.Parser.TreeSitter.Go import Text.Parser.TreeSitter.Python import Text.Parser.TreeSitter.Ruby import Text.Parser.TreeSitter.TypeScript +import Text.Parser.TreeSitter.JSON import TreeSitter -- | A parser from 'Source' onto some term type. @@ -58,6 +59,7 @@ parserForLanguage Nothing = LineByLineParser parserForLanguage (Just language) = case language of C -> TreeSitterParser C tree_sitter_c Go -> TreeSitterParser Go tree_sitter_go + JSON -> TreeSitterParser JSON tree_sitter_json JavaScript -> TreeSitterParser TypeScript tree_sitter_typescript Ruby -> TreeSitterParser Ruby tree_sitter_ruby TypeScript -> TreeSitterParser TypeScript tree_sitter_typescript From 381d5e741fcdb2ce0c293c21a53d34652badc4aa Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 19 Jul 2017 15:17:00 -0400 Subject: [PATCH 04/11] Add some structure to JSON.Syntax --- semantic-diff.cabal | 1 + src/Language/JSON/Syntax.hs | 46 +++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100644 src/Language/JSON/Syntax.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index ae8c8abad..5165ada7d 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -52,6 +52,7 @@ library , Language.Go , Language.Go.Syntax , Language.JSON.Grammar + , Language.JSON.Syntax , Language.Ruby , Language.Ruby.Grammar , Language.Ruby.Syntax diff --git a/src/Language/JSON/Syntax.hs b/src/Language/JSON/Syntax.hs new file mode 100644 index 000000000..ef952df65 --- /dev/null +++ b/src/Language/JSON/Syntax.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators #-} +module Language.JSON.Syntax + ( assignment + , Syntax + , Grammar + , Term) + where + +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Literal as Literal +import Data.Syntax.Assignment hiding (Assignment, Error) +import qualified Data.Syntax.Assignment as Assignment +import Language.JSON.Grammar as Grammar +import qualified Term +import Data.Record +import Data.Union +import GHC.Stack +import Prologue hiding (Location) + +type Syntax = + '[ Literal.Hash + , Syntax.Error + ] + +type Term = Term.Term (Union Syntax) (Record Location) +type Assignment = HasCallStack => Assignment.Assignment (AST Grammar) Grammar Term + + +makeTerm :: (HasCallStack, f :< fs) => a -> f (Term.Term (Union fs) a) -> Term.Term (Union fs) a +makeTerm a f = cofree (a :< inj f) + +parseError :: Assignment +parseError = makeTerm <$> symbol ParseError <*> (Syntax.Error [] <$ source) + +assignment :: Assignment +assignment = object <|> array <|> parseError + +object :: Assignment +object = makeTerm <$> symbol Object <*> children (Literal.Hash <$> many pairs) + where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> expression) + +array :: Assignment +array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many expression) + + + From e637d195b942b74fefb56b26b182f62db2ce594b Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 19 Jul 2017 15:26:00 -0400 Subject: [PATCH 05/11] Add remaining json syntax --- src/Language/JSON/Syntax.hs | 26 ++++++++++++++++++++++++-- src/Parser.hs | 5 +++++ src/Semantic.hs | 3 +++ 3 files changed, 32 insertions(+), 2 deletions(-) diff --git a/src/Language/JSON/Syntax.hs b/src/Language/JSON/Syntax.hs index ef952df65..b51bbf4a9 100644 --- a/src/Language/JSON/Syntax.hs +++ b/src/Language/JSON/Syntax.hs @@ -19,7 +19,15 @@ import Prologue hiding (Location) type Syntax = '[ Literal.Hash + , Literal.KeyValue + , Literal.Null + , Literal.String + , Literal.TextElement , Syntax.Error + , Literal.Array + , Literal.Boolean + , Literal.Float + , [] ] type Term = Term.Term (Union Syntax) (Record Location) @@ -35,12 +43,26 @@ parseError = makeTerm <$> symbol ParseError <*> (Syntax.Error [] <$ source) assignment :: Assignment assignment = object <|> array <|> parseError +value :: Assignment +value = object <|> array <|> number <|> string <|> boolean <|> none + object :: Assignment object = makeTerm <$> symbol Object <*> children (Literal.Hash <$> many pairs) - where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> expression) + where pairs = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> (number <|> string) <*> value) array :: Assignment -array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many expression) +array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many value) +number :: Assignment +number = makeTerm <$> symbol Number <*> (Literal.Float <$> source) +string :: Assignment +string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) + +boolean :: Assignment +boolean = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ source) + <|> makeTerm <$> symbol Grammar.False <*> (Literal.false <$ source) + +none :: Assignment +none = makeTerm <$> symbol Null <*> (Literal.Null <$ source) diff --git a/src/Parser.hs b/src/Parser.hs index c469ebafa..2813a78d1 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -5,6 +5,7 @@ module Parser -- Syntax parsers , parserForLanguage -- À la carte parsers +, jsonParser , markdownParser , pythonParser , rubyParser @@ -20,6 +21,7 @@ import Data.Union import Info hiding (Empty, Go) import Language import Language.Markdown +import qualified Language.JSON.Syntax as JSON import qualified Language.Markdown.Syntax as Markdown import qualified Language.Python.Syntax as Python import qualified Language.Ruby.Syntax as Ruby @@ -71,6 +73,9 @@ rubyParser = AssignmentParser (ASTParser tree_sitter_ruby) headF Ruby.assignment pythonParser :: Parser Python.Term pythonParser = AssignmentParser (ASTParser tree_sitter_python) headF Python.assignment +jsonParser :: Parser JSON.Term +jsonParser = AssignmentParser (ASTParser tree_sitter_json) headF JSON.assignment + markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment diff --git a/src/Semantic.hs b/src/Semantic.hs index 25eb0641c..711cea500 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -70,12 +70,15 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (ToCDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms (renderToCDiff blobs) (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs) + (JSONDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs) (PatchDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderPatch blobs) (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderPatch blobs) + (PatchDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderPatch blobs) (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs) (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse markdownParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) (SExpressionDiffRenderer, Just Language.Python) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse jsonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory) (IdentityDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms Just where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) From c513e6e34b9d881199001d204fda03cbd5ad267c Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 19 Jul 2017 17:26:22 -0400 Subject: [PATCH 06/11] Merge origin/master --- semantic-diff.cabal | 1 + src/Data/Syntax/Assignment.hs | 90 ++++++++++++----------------- src/Decorators.hs | 59 +++++++++++++++++++ src/Interpreter.hs | 10 +--- src/Language/Markdown/Syntax.hs | 5 +- src/Parser.hs | 8 ++- src/Renderer/TOC.hs | 42 ++++++++------ src/Semantic.hs | 24 +++----- test/Data/Syntax/Assignment/Spec.hs | 56 +++++++++++------- test/TOCSpec.hs | 22 +++---- test/fixtures/markdown/example.A.md | 1 + 11 files changed, 190 insertions(+), 128 deletions(-) create mode 100644 src/Decorators.hs create mode 100644 test/fixtures/markdown/example.A.md diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 5165ada7d..bdce25e6f 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -42,6 +42,7 @@ library , Data.Syntax.Statement , Data.Syntax.Type , Data.Text.Listable + , Decorators , Diff , Info , Interpreter diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index f1268ba60..9373a91e0 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -74,7 +74,6 @@ module Data.Syntax.Assignment , children , while -- Results -, Result(..) , Error(..) , ErrorCause(..) , printError @@ -172,10 +171,6 @@ nodeLocation :: Node grammar -> Record Location nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil --- | The result of assignment, possibly containing an error. -data Result grammar a = Result { resultError :: Maybe (Error grammar), resultValue :: Maybe a } - deriving (Eq, Foldable, Functor, Traversable) - data Error grammar where Error :: HasCallStack @@ -194,13 +189,15 @@ data ErrorCause grammar -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Source.Source -> Error grammar -> IO () printError source error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . showPos Nothing errorPos . showString ": " $ "" - withSGRCode [SetColor Foreground Vivid Red] . putStrErr . showString "error" . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') $ "" - withSGRCode [SetColor Foreground Vivid Green] . putStrErr . showChar '^' . showChar '\n' . showString (prettyCallStack callStack) $ "" + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos Nothing errorPos . showString ": " + withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' + putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') + withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n' + putStrErr $ showString (prettyCallStack callStack) . showChar '\n' where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) - putStrErr = hPutStr stderr + putStrErr = hPutStr stderr . ($ "") withSGRCode :: [SGR] -> IO a -> IO () withSGRCode code action = do @@ -230,42 +227,45 @@ showPos :: Maybe FilePath -> Info.Pos -> ShowS showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn -- | Run an assignment over an AST exhaustively. -assign :: (HasField fields Info.Range, HasField fields Info.Span, HasField fields grammar, Symbol grammar, Enum grammar, Eq grammar, Traversable f, HasCallStack) => Assignment (Cofree f (Record fields)) grammar a -> Source.Source -> Cofree f (Record fields) -> Result grammar a +assign :: (HasField fields Info.Range, HasField fields Info.Span, HasField fields grammar, Symbol grammar, Enum grammar, Eq grammar, Traversable f, HasCallStack) => Assignment (Cofree f (Record fields)) grammar a -> Source.Source -> Cofree f (Record fields) -> Either (Error grammar) a assign = assignBy (\ (r :< _) -> Node (getField r) (getField r) (getField r)) -assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> Source.Source -> ast -> Result grammar a +assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> Source.Source -> ast -> Either (Error grammar) a assignBy toNode assignment source = fmap fst . assignAllFrom toNode assignment . makeState source . pure -assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> AssignmentState ast -> Result grammar (a, AssignmentState ast) -assignAllFrom toNode assignment state = case runAssignment toNode assignment state of - Result err (Just (a, state)) -> case stateNodes (dropAnonymous toNode state) of - [] -> pure (a, state) - node : _ -> Result (err <|> Just (Error (statePos state) (UnexpectedSymbol [] (nodeSymbol (toNode (F.project node)))))) Nothing - r -> r +assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) +assignAllFrom toNode assignment state = runAssignment toNode assignment state >>= go + where + go (a, state) = case stateNodes (dropAnonymous toNode state) of + [] -> Right (a, state) + node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in + Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state) -- | Run an assignment of nodes in a grammar onto terms in a syntax. -runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> AssignmentState ast -> Result grammar (a, AssignmentState ast) +runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack) => (forall x. Base ast x -> Node grammar) -> Assignment ast grammar a -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) - where run :: AssignmentF ast grammar x -> (x -> AssignmentState ast -> Result grammar (a, AssignmentState ast)) -> AssignmentState ast -> Result grammar (a, AssignmentState ast) + where run :: AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar) run assignment yield initialState = case (assignment, stateNodes) of (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state (Location, []) -> yield (Info.Range stateOffset stateOffset :. Info.Span statePos statePos :. Nil) state (Project projection, node : _) -> yield (projection (F.project node)) state (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) stateSource)) (advanceState toNode state) - (Children childAssignment, node : _) -> case assignAllFrom toNode childAssignment state { stateNodes = toList (F.project node) } of - Result _ (Just (a, state')) -> yield a (advanceState toNode state' { stateNodes = stateNodes }) - Result err Nothing -> Result err Nothing + (Children childAssignment, node : _) -> do + (a, state') <- assignAllFrom toNode childAssignment state { stateNodes = toList (F.project node) } + yield a (advanceState toNode state' { stateNodes = stateNodes }) (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state (Many _, []) -> yield [] state (Many rule, _) -> uncurry yield (runMany rule state) -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input. - (Alt a b, _) -> yield a state <|> yield b state - (Throw e, _) -> Result (Just e) Nothing + (Alt a b, _) -> case yield a state of + Left err -> yield b state { stateError = Just err } + r -> r + (Throw e, _) -> Left e (Catch during handler, _) -> case yield during state of - Result _ (Just (a, state')) -> pure (a, state') - Result err Nothing -> maybe empty (flip yield state . handler) err - (_, []) -> Result (Just (Error statePos (UnexpectedEndOfInput expectedSymbols))) Nothing - (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Result (Just (Error spanStart (UnexpectedSymbol expectedSymbols symbol))) Nothing + Left err -> yield (handler err) state + Right (a, state') -> Right (a, state') + (_, []) -> Left (Error statePos (UnexpectedEndOfInput expectedSymbols)) + (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol)) where state@AssignmentState{..} = case assignment of Choose choices | all ((== Regular) . symbolType) (choiceSymbols choices) -> dropAnonymous toNode initialState _ -> initialState @@ -273,33 +273,34 @@ runAssignment toNode = iterFreer run . fmap ((pure .) . (,)) Choose choices -> choiceSymbols choices _ -> [] choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices - runMany :: Assignment ast grammar v -> AssignmentState ast -> ([v], AssignmentState ast) + runMany :: Assignment ast grammar v -> AssignmentState ast grammar -> ([v], AssignmentState ast grammar) runMany rule state = case runAssignment toNode rule state of - Result _ (Just (a, state')) -> let (as, state'') = runMany rule state' in as `seq` (a : as, state'') - _ -> ([], state) + Left e -> ([], state { stateError = Just e }) + Right (a, state') -> let (as, state'') = runMany rule state' in as `seq` (a : as, state'') {-# INLINE run #-} -dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast -> AssignmentState ast +dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) } -- | Advances the state past the current (head) node (if any), dropping it off stateNodes & its corresponding bytes off of stateSource, and updating stateOffset & statePos to its end. Exhausted 'AssignmentState's (those without any remaining nodes) are returned unchanged. -advanceState :: Recursive ast => (forall x. Base ast x -> Node grammar) -> AssignmentState ast -> AssignmentState ast +advanceState :: Recursive ast => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar advanceState toNode state@AssignmentState{..} | node : rest <- stateNodes - , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateSource rest + , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError stateSource rest | otherwise = state -- | State kept while running 'Assignment's. -data AssignmentState ast = AssignmentState +data AssignmentState ast grammar = AssignmentState { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes. , statePos :: Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached. + , stateError :: Maybe (Error grammar) , stateSource :: Source.Source -- ^ The remaining Source. Equal to dropping 'stateOffset' bytes off the original input Source. , stateNodes :: [ast] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.” } deriving (Eq, Show) -makeState :: Source.Source -> [ast] -> AssignmentState ast -makeState = AssignmentState 0 (Info.Pos 1 1) +makeState :: Source.Source -> [ast] -> AssignmentState ast grammar +makeState = AssignmentState 0 (Info.Pos 1 1) Nothing -- Instances @@ -330,12 +331,6 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where Throw e -> showsUnaryWith showsPrec "Throw" d e Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler -instance Show2 Result where - liftShowsPrec2 sp1 sl1 sp2 sl2 d (Result es a) = showsBinaryWith (liftShowsPrec (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1)) (liftShowsPrec sp2 sl2) "Result" d es a - -instance (Show grammar, Show a) => Show (Result grammar a) where - showsPrec = showsPrec2 - instance Show1 Error where liftShowsPrec sp sl d (Error p c) = showsBinaryWith showsPrec (liftShowsPrec sp sl) "Error" d p c @@ -344,15 +339,6 @@ instance Show1 ErrorCause where UnexpectedSymbol expected actual -> showsBinaryWith (liftShowsPrec sp sl) sp "UnexpectedSymbol" d expected actual UnexpectedEndOfInput expected -> showsUnaryWith (liftShowsPrec sp sl) "UnexpectedEndOfInput" d expected -instance Applicative (Result grammar) where - pure = Result Nothing . Just - Result e1 f <*> Result e2 a = Result (e1 <|> e2) (f <*> a) - -instance Alternative (Result grammar) where - empty = Result Nothing Nothing - Result e (Just a) <|> _ = Result e (Just a) - Result e1 Nothing <|> Result e2 b = Result (e1 <|> e2) b - instance MonadError (Error grammar) (Assignment ast grammar) where throwError :: HasCallStack => Error grammar -> Assignment ast grammar a throwError error = withFrozenCallStack $ Throw error `Then` return diff --git a/src/Decorators.hs b/src/Decorators.hs new file mode 100644 index 000000000..fa25ce1e6 --- /dev/null +++ b/src/Decorators.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module Decorators +( ConstructorLabel(..) +, constructorNameAndConstantFields +, constructorLabel +) where + +import Data.Aeson +import Data.Functor.Classes (Show1 (liftShowsPrec)) +import Data.Union +import Data.String +import GHC.Generics +import Prologue +import Renderer.JSON +import Term +import Text.Show + + +-- | Compute a 'ByteString' label for a 'Show1'able 'Term'. +-- +-- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that +-- constant fields will be included and parametric fields will not be. +constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString +constructorNameAndConstantFields (_ :< f) = toS (liftShowsPrec (const (const identity)) (const identity) 0 f "") + +-- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's. +constructorLabel :: ConstructorName f => TermF f a b -> ConstructorLabel +constructorLabel (_ :< f) = ConstructorLabel $ toS (constructorName f) + + +newtype ConstructorLabel = ConstructorLabel ByteString + +instance Show ConstructorLabel where + showsPrec _ (ConstructorLabel s) = showString (toS s) + +instance ToJSONFields ConstructorLabel where + toJSONFields (ConstructorLabel s) = [ "category" .= (toS s :: Text) ] + + +class ConstructorName f where + constructorName :: f a -> String + +instance (Generic1 f, ConstructorName (Rep1 f), ConstructorName (Union fs)) => ConstructorName (Union (f ': fs)) where + constructorName union = case decompose union of + Left rest -> constructorName rest + Right f -> constructorName (from1 f) + +instance ConstructorName (Union '[]) where + constructorName _ = "" + +instance ConstructorName f => ConstructorName (M1 D c f) where + constructorName = constructorName . unM1 + +instance Constructor c => ConstructorName (M1 C c f) where + constructorName = conName + +instance (ConstructorName f, ConstructorName g) => ConstructorName (f :+: g) where + constructorName (L1 l) = constructorName l + constructorName (R1 r) = constructorName r diff --git a/src/Interpreter.hs b/src/Interpreter.hs index ef776a633..59011e056 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -4,7 +4,6 @@ module Interpreter , decoratingWith , diffTermsWith , comparableByConstructor -, constructorLabel , runAlgorithm , runAlgorithmSteps ) where @@ -13,7 +12,7 @@ import Algorithm import Control.Monad.Free.Freer import Data.Align.Generic import Data.Functor.Both -import Data.Functor.Classes (Eq1, Show1 (liftShowsPrec)) +import Data.Functor.Classes (Eq1) import RWS import Data.Record import Data.These @@ -24,6 +23,7 @@ import Prologue hiding (lookup) import Syntax as S hiding (Return) import Term + -- | Diff two terms recursively, given functions characterizing the diffing. diffTerms :: (Eq leaf, Hashable leaf, HasField fields Category) => Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively. @@ -62,12 +62,6 @@ getLabel (h :< t) = (Info.category h, case t of Leaf s -> Just s _ -> Nothing) --- | Compute a 'ByteString' label for a 'Show1'able 'Term'. --- --- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that constant fields will be included and parametric fields will not be. -constructorLabel :: Show1 f => TermF f a b -> ByteString -constructorLabel (_ :< f) = toS (liftShowsPrec (const (const identity)) (const identity) 0 f "") - -- | Run an Algorithm to completion by repeated application of a stepping operation and return its result. runAlgorithm :: forall f result . (forall x. f x -> Freer f x) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 52a6bc10e..eaceb529b 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -91,7 +91,7 @@ htmlBlock = makeTerm <$> symbol HTMLBlock <*> (Markup.HTMLBlock <$> source) -- Inline elements inlineElement :: Assignment -inlineElement = strong <|> emphasis <|> text <|> link <|> image <|> code <|> lineBreak <|> softBreak +inlineElement = strong <|> emphasis <|> text <|> link <|> htmlInline <|> image <|> code <|> lineBreak <|> softBreak strong :: Assignment strong = makeTerm <$> symbol Strong <*> children (Markup.Strong <$> many inlineElement) @@ -102,6 +102,9 @@ emphasis = makeTerm <$> symbol Emphasis <*> children (Markup.Emphasis <$> many i text :: Assignment text = makeTerm <$> symbol Text <*> (Markup.Text <$> source) +htmlInline :: Assignment +htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source) + link :: Assignment link = makeTerm <$> symbol Link <*> project (\ (Node (CMark.LINK url title) _ _ :< _) -> Markup.Link (toS url) (nullText title)) <* source diff --git a/src/Parser.hs b/src/Parser.hs index 2813a78d1..e3312ce05 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -84,9 +84,11 @@ runParser parser = case parser of ASTParser language -> parseToAST language AssignmentParser parser by assignment -> \ source -> do ast <- runParser parser source - let Result err term = assignBy by assignment source ast - traverse_ (printError source) (toList err) - pure $! fromMaybe (errorTerm source) term + case assignBy by assignment source ast of + Left err -> do + printError source err + pure (errorTerm source) + Right term -> pure term TreeSitterParser language tslanguage -> treeSitterParser language tslanguage MarkdownParser -> pure . cmarkParser LineByLineParser -> pure . lineByLineParser diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index fad5509c9..9c249cf04 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -33,6 +33,7 @@ import Data.These import Data.Union import Diff import Info +import Language import Patch import Prologue import qualified Data.List as List @@ -64,12 +65,12 @@ data JSONSummary , summarySpan :: Span , summaryChangeType :: Text } - | ErrorSummary { error :: Text, errorSpan :: Span } + | ErrorSummary { error :: Text, errorSpan :: Span, errorLanguage :: Maybe Language } deriving (Generic, Eq, Show) instance ToJSON JSONSummary where toJSON JSONSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ] - toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan ] + toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan, "language" .= errorLanguage ] isValidSummary :: JSONSummary -> Bool isValidSummary ErrorSummary{} = False @@ -171,25 +172,30 @@ dedupe = foldl' go [] similarDeclaration = (==) `on` fmap (toLower . declarationIdentifier) . getDeclaration -- | Construct a 'JSONSummary' from an 'Entry'. Returns 'Nothing' for 'Unchanged' patches. -entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Entry (Record fields) -> Maybe JSONSummary -entrySummary entry = case entry of +entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Maybe Language -> Entry (Record fields) -> Maybe JSONSummary +entrySummary language entry = case entry of Unchanged _ -> Nothing - Changed a -> recordSummary a "modified" - Deleted a -> recordSummary a "removed" - Inserted a -> recordSummary a "added" - Replaced a -> recordSummary a "modified" + Changed a -> recordSummary language a "modified" + Deleted a -> recordSummary language a "removed" + Inserted a -> recordSummary language a "added" + Replaced a -> recordSummary language a "modified" -- | Construct a 'JSONSummary' from a node annotation and a change type label. -recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Record fields -> Text -> Maybe JSONSummary -recordSummary record = case getDeclaration record of - Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record)) +recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Maybe Language -> Record fields -> Text -> Maybe JSONSummary +recordSummary language record = case getDeclaration record of + Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record) language) Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record) Nothing -> const Nothing renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Both Blob -> Diff f (Record fields) -> Summaries -renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC +renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC language where toMap [] = mempty toMap as = Map.singleton summaryKey (toJSON <$> as) + language = case runJoin (blobLanguage <$> blobs) of + (Nothing, Just after) -> Just after + (Just before, Nothing) -> Just before + (Nothing, Nothing) -> Nothing + (Just before, Just _) -> Just before summaryKey = toS $ case runJoin (blobPath <$> blobs) of (before, after) | null before -> after | null after -> before @@ -197,15 +203,15 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV | otherwise -> before <> " -> " <> after renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Blob -> Term f (Record fields) -> Summaries -renderToCTerm blob = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC +renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC blobLanguage where toMap [] = mempty - toMap as = Map.singleton (toS (blobPath blob)) (toJSON <$> as) + toMap as = Map.singleton (toS blobPath) (toJSON <$> as) -diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Diff f (Record fields) -> [JSONSummary] -diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration +diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Maybe Language -> Diff f (Record fields) -> [JSONSummary] +diffTOC language = mapMaybe (entrySummary language) . dedupe . tableOfContentsBy declaration -termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Term f (Record fields) -> [JSONSummary] -termToC = mapMaybe (flip recordSummary "unchanged") . termTableOfContentsBy declaration +termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Maybe Language -> Term f (Record fields) -> [JSONSummary] +termToC language = mapMaybe (flip (recordSummary language) "unchanged") . termTableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> Text diff --git a/src/Semantic.hs b/src/Semantic.hs index 711cea500..0444e98f2 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -16,6 +16,7 @@ import Data.Record import Data.Source import qualified Data.Syntax.Declaration as Declaration import Data.Union +import Decorators import Diff import Info import Interpreter @@ -26,7 +27,6 @@ import Prologue import Renderer import Semantic.Task as Task import Term -import Text.Show -- This is the primary interface to the Semantic library which provides two -- major classes of functionality: semantic parsing and diffing of source code @@ -46,11 +46,11 @@ parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) (ToCTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) (ToCTermRenderer, _) -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource) >>= render (renderToCTerm blob) - (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= render (renderJSONTerm blob) - (JSONTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= render (renderJSONTerm blob) + (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) + (JSONTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) (JSONTermRenderer, _) -> parse syntaxParser blobSource >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) - (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate (ConstructorLabel . constructorLabel) >>= render renderSExpressionTerm . fmap keepConstructorLabel - (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate (ConstructorLabel . constructorLabel) >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel (SExpressionTermRenderer, _) -> parse syntaxParser blobSource >>= render renderSExpressionTerm . fmap keepCategory (IdentityTermRenderer, Just Language.Markdown) -> pure Nothing (IdentityTermRenderer, Just Language.Python) -> pure Nothing @@ -76,9 +76,9 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderPatch blobs) (PatchDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderPatch blobs) (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs) - (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse markdownParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) - (SExpressionDiffRenderer, Just Language.Python) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) - (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate (ConstructorLabel . constructorLabel) <=< parse jsonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) + (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory) (IdentityDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms Just where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) @@ -88,7 +88,7 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of run parse diff renderer = distributeFor blobs (parse . blobSource) >>= diffTermPair blobs diff >>= render renderer diffLinearly :: (Eq1 f, GAlign f, Show1 f, Traversable f) => Both (Term f (Record fields)) -> Diff f (Record fields) - diffLinearly = decoratingWith constructorLabel (diffTermsWith linearly comparableByConstructor) + diffLinearly = decoratingWith constructorNameAndConstantFields (diffTermsWith linearly comparableByConstructor) -- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. diffTermPair :: Functor f => Both Blob -> Differ f a -> Both (Term f a) -> Task (Diff f a) @@ -103,9 +103,3 @@ keepCategory = (:. Nil) . category keepConstructorLabel :: Record (ConstructorLabel ': fields) -> Record '[ConstructorLabel] keepConstructorLabel = (:. Nil) . rhead - - -newtype ConstructorLabel = ConstructorLabel ByteString - -instance Show ConstructorLabel where - showsPrec _ (ConstructorLabel s) = showString (toS s) diff --git a/test/Data/Syntax/Assignment/Spec.hs b/test/Data/Syntax/Assignment/Spec.hs index 8fcff75c7..6220e44e3 100644 --- a/test/Data/Syntax/Assignment/Spec.hs +++ b/test/Data/Syntax/Assignment/Spec.hs @@ -13,61 +13,77 @@ spec :: Spec spec = do describe "Applicative" $ it "matches in sequence" $ - runAssignment headF ((,) <$> red <*> red) (makeState "helloworld" [node Red 0 5 [], node Red 5 10 []]) `shouldBe` Result Nothing (Just ((Out "hello", Out "world"), AssignmentState 10 (Info.Pos 1 11) "helloworld" [])) + runAssignment headF ((,) <$> red <*> red) (makeState "helloworld" [node Red 0 5 [], node Red 5 10 []]) + `shouldBe` + Right ((Out "hello", Out "world"), AssignmentState 10 (Info.Pos 1 11) Nothing "helloworld" []) describe "Alternative" $ do it "attempts multiple alternatives" $ - runAssignment headF (green <|> red) (makeState "hello" [node Red 0 5 []]) `shouldBe` Result Nothing (Just (Out "hello", AssignmentState 5 (Info.Pos 1 6) "hello" [])) + runAssignment headF (green <|> red) (makeState "hello" [node Red 0 5 []]) + `shouldBe` + Right (Out "hello", AssignmentState 5 (Info.Pos 1 6) Nothing "hello" []) it "matches repetitions" $ let s = "colourless green ideas sleep furiously" w = words s (_, nodes) = foldl (\ (i, prev) word -> (i + B.length word + 1, prev <> [node Red i (i + B.length word) []])) (0, []) w in - resultValue (runAssignment headF (many red) (makeState (fromBytes s) nodes)) `shouldBe` Just (Out <$> w, AssignmentState (B.length s) (Info.Pos 1 (succ (B.length s))) (fromBytes s) []) + runAssignment headF (many red) (makeState (fromBytes s) nodes) + `shouldBe` + Right (Out <$> w, AssignmentState (B.length s) + (Info.Pos 1 (succ (B.length s))) + (Just (Error (Info.Pos 1 39) (UnexpectedEndOfInput [Red]))) + (fromBytes s) + []) it "matches one-or-more repetitions against one or more input nodes" $ - resultValue (runAssignment headF (some red) (makeState "hello" [node Red 0 5 []])) `shouldBe` Just ([Out "hello"], AssignmentState 5 (Info.Pos 1 6) "hello" []) + runAssignment headF (some red) (makeState "hello" [node Red 0 5 []]) + `shouldBe` + Right ([Out "hello"], AssignmentState 5 + (Info.Pos 1 6) + (Just (Error (Info.Pos 1 6) (UnexpectedEndOfInput [Red]))) + "hello" + []) describe "symbol" $ do it "matches nodes with the same symbol" $ - fst <$> runAssignment headF red (makeState "hello" [node Red 0 5 []]) `shouldBe` Result Nothing (Just (Out "hello")) + fst <$> runAssignment headF red (makeState "hello" [node Red 0 5 []]) `shouldBe` Right (Out "hello") it "does not advance past the current node" $ let initialState = makeState "hi" [ node Red 0 2 [] ] in - snd <$> runAssignment headF (symbol Red) initialState `shouldBe` Result Nothing (Just initialState) + snd <$> runAssignment headF (symbol Red) initialState `shouldBe` Right initialState describe "source" $ do it "produces the node’s source" $ - assignBy headF source "hi" (node Red 0 2 []) `shouldBe` Result Nothing (Just "hi") + assignBy headF source "hi" (node Red 0 2 []) `shouldBe` Right "hi" it "advances past the current node" $ - snd <$> runAssignment headF source (makeState "hi" [ node Red 0 2 [] ]) `shouldBe` Result Nothing (Just (AssignmentState 2 (Info.Pos 1 3) "hi" [])) + snd <$> runAssignment headF source (makeState "hi" [ node Red 0 2 [] ]) `shouldBe` Right (AssignmentState 2 (Info.Pos 1 3) Nothing "hi" []) describe "children" $ do it "advances past the current node" $ - snd <$> runAssignment headF (children (pure (Out ""))) (makeState "a" [node Red 0 1 []]) `shouldBe` Result Nothing (Just (AssignmentState 1 (Info.Pos 1 2) "a" [])) + snd <$> runAssignment headF (children (pure (Out ""))) (makeState "a" [node Red 0 1 []]) `shouldBe` Right (AssignmentState 1 (Info.Pos 1 2) Nothing "a" []) it "matches if its subrule matches" $ - () <$ runAssignment headF (children red) (makeState "a" [node Blue 0 1 [node Red 0 1 []]]) `shouldBe` Result Nothing (Just ()) + () <$ runAssignment headF (children red) (makeState "a" [node Blue 0 1 [node Red 0 1 []]]) `shouldBe` Right () it "does not match if its subrule does not match" $ - (runAssignment headF (children red) (makeState "a" [node Blue 0 1 [node Green 0 1 []]])) `shouldBe` Result (Just (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green))) Nothing + runAssignment headF (children red) (makeState "a" [node Blue 0 1 [node Green 0 1 []]]) `shouldBe` Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green)) it "matches nested children" $ runAssignment headF (symbol Red *> children (symbol Green *> children (symbol Blue *> source))) (makeState "1" [ node Red 0 1 [ node Green 0 1 [ node Blue 0 1 [] ] ] ]) `shouldBe` - Result Nothing (Just ("1", AssignmentState 1 (Info.Pos 1 2) "1" [])) + Right ("1", AssignmentState 1 (Info.Pos 1 2) Nothing "1" []) it "continues after children" $ - resultValue (runAssignment headF + runAssignment headF (many (symbol Red *> children (symbol Green *> source) <|> symbol Blue *> source)) (makeState "BC" [ node Red 0 1 [ node Green 0 1 [] ] - , node Blue 1 2 [] ])) + , node Blue 1 2 [] ]) `shouldBe` - Just (["B", "C"], AssignmentState 2 (Info.Pos 1 3) "BC" []) + Right (["B", "C"], AssignmentState 2 (Info.Pos 1 3) (Just (Error (Info.Pos 1 3) (UnexpectedEndOfInput [Red, Blue]))) "BC" []) it "matches multiple nested children" $ runAssignment headF @@ -75,20 +91,20 @@ spec = do (makeState "12" [ node Red 0 2 [ node Green 0 1 [ node Blue 0 1 [] ] , node Green 1 2 [ node Blue 1 2 [] ] ] ]) `shouldBe` - Result Nothing (Just (["1", "2"], AssignmentState 2 (Info.Pos 1 3) "12" [])) + Right (["1", "2"], AssignmentState 2 (Info.Pos 1 3) (Just (Error (Info.Pos 1 3) (UnexpectedEndOfInput [Green]))) "12" []) describe "runAssignment" $ do it "drops anonymous nodes before matching symbols" $ - runAssignment headF red (makeState "magenta red" [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Result Nothing (Just (Out "red", AssignmentState 11 (Info.Pos 1 12) "magenta red" [])) + runAssignment headF red (makeState "magenta red" [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Right (Out "red", AssignmentState 11 (Info.Pos 1 12) Nothing "magenta red" []) it "does not drop anonymous nodes after matching" $ - runAssignment headF red (makeState "red magenta" [node Red 0 3 [], node Magenta 4 11 []]) `shouldBe` Result Nothing (Just (Out "red", AssignmentState 3 (Info.Pos 1 4) "red magenta" [node Magenta 4 11 []])) + runAssignment headF red (makeState "red magenta" [node Red 0 3 [], node Magenta 4 11 []]) `shouldBe` Right (Out "red", AssignmentState 3 (Info.Pos 1 4) Nothing "red magenta" [node Magenta 4 11 []]) it "does not drop anonymous nodes when requested" $ - runAssignment headF ((,) <$> magenta <*> red) (makeState "magenta red" [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Result Nothing (Just ((Out "magenta", Out "red"), AssignmentState 11 (Info.Pos 1 12) "magenta red" [])) + runAssignment headF ((,) <$> magenta <*> red) (makeState "magenta red" [node Magenta 0 7 [], node Red 8 11 []]) `shouldBe` Right ((Out "magenta", Out "red"), AssignmentState 11 (Info.Pos 1 12) Nothing "magenta red" []) node :: symbol -> Int -> Int -> [AST symbol] -> AST symbol -node symbol start end children = cofree $ (Node symbol (Range start end) (Info.Span (Info.Pos 1 (succ start)) (Info.Pos 1 (succ end)))) :< children +node symbol start end children = cofree $ Node symbol (Range start end) (Info.Span (Info.Pos 1 (succ start)) (Info.Pos 1 (succ end))) :< children data Grammar = Red | Green | Blue | Magenta deriving (Enum, Eq, Show) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index caecace4d..e270b948e 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -55,12 +55,12 @@ spec = parallel $ do describe "diffTOC" $ do it "blank if there are no methods" $ - diffTOC blankDiff `shouldBe` [ ] + diffTOC Nothing blankDiff `shouldBe` [ ] it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC (Just Ruby) diff `shouldBe` [ JSONSummary "Method" "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added" , JSONSummary "Method" "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified" , JSONSummary "Method" "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ] @@ -68,37 +68,37 @@ spec = parallel $ do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC Nothing diff `shouldBe` [ JSONSummary "Function" "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC (Just JavaScript) diff `shouldBe` [ JSONSummary "Function" "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC (Just Language.Go) diff `shouldBe` [ JSONSummary "Method" "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC (Just Ruby) diff `shouldBe` [ JSONSummary "Method" "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` + diffTOC (Just Ruby) diff `shouldBe` [ JSONSummary "Method" "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (both "javascript/starts-with-newline.js" "javascript/starts-with-newline.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC diff `shouldBe` [] + diffTOC (Just JavaScript) diff `shouldBe` [] prop "inserts of methods and functions are summarized" $ \name body -> @@ -127,7 +127,7 @@ spec = parallel $ do prop "equal terms produce identity diffs" $ \a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in - diffTOC (diffTerms (pure term)) `shouldBe` [] + diffTOC Nothing (diffTerms (pure term)) `shouldBe` [] describe "JSONSummary" $ do it "encodes modified summaries to JSON" $ do @@ -147,7 +147,7 @@ spec = parallel $ do it "produces JSON output if there are parse errors" $ do blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb") output <- runTask (diffBlobPair ToCDiffRenderer blobs) - toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\"}]}}\n" :: ByteString) + toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\",\"language\":\"Ruby\"}]}}\n" :: ByteString) it "summarizes Markdown headings" $ do blobs <- blobsForPaths (both "markdown/headings.A.md" "markdown/headings.B.md") @@ -159,7 +159,7 @@ type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields) type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields) numTocSummaries :: Diff' -> Int -numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) +numTocSummaries diff = length $ filter isValidSummary (diffTOC Nothing diff) -- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff. programWithChange :: Term' -> Diff' diff --git a/test/fixtures/markdown/example.A.md b/test/fixtures/markdown/example.A.md new file mode 100644 index 000000000..a4082cfc4 --- /dev/null +++ b/test/fixtures/markdown/example.A.md @@ -0,0 +1 @@ +a b From 00205c3d2686f3d2a35beb17950be12b1ba42a88 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 20 Jul 2017 11:04:13 -0400 Subject: [PATCH 07/11] Sort Syntax in JSON parser --- src/Language/JSON/Syntax.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Language/JSON/Syntax.hs b/src/Language/JSON/Syntax.hs index b51bbf4a9..fa207365e 100644 --- a/src/Language/JSON/Syntax.hs +++ b/src/Language/JSON/Syntax.hs @@ -18,17 +18,17 @@ import GHC.Stack import Prologue hiding (Location) type Syntax = - '[ Literal.Hash - , Literal.KeyValue - , Literal.Null - , Literal.String - , Literal.TextElement - , Syntax.Error - , Literal.Array - , Literal.Boolean - , Literal.Float - , [] - ] + [ Literal.Array + , Literal.Boolean + , Literal.Hash + , Literal.Float + , Literal.KeyValue + , Literal.Null + , Literal.String + , Literal.TextElement + , Syntax.Error + , [] + ] type Term = Term.Term (Union Syntax) (Record Location) type Assignment = HasCallStack => Assignment.Assignment (AST Grammar) Grammar Term From fb84ec83f509aa8b8500e8c8bb5c56d024a2820e Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 20 Jul 2017 11:04:19 -0400 Subject: [PATCH 08/11] Add JSON to parseBlob --- src/Semantic.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic.hs b/src/Semantic.hs index 0444e98f2..22c370157 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -45,15 +45,19 @@ parseBlob :: TermRenderer output -> Blob -> Task output parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) (ToCTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) + (ToCTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) (ToCTermRenderer, _) -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource) >>= render (renderToCTerm blob) (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) (JSONTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) + (JSONTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) (JSONTermRenderer, _) -> parse syntaxParser blobSource >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel (SExpressionTermRenderer, _) -> parse syntaxParser blobSource >>= render renderSExpressionTerm . fmap keepCategory (IdentityTermRenderer, Just Language.Markdown) -> pure Nothing (IdentityTermRenderer, Just Language.Python) -> pure Nothing + (IdentityTermRenderer, Just Language.JSON) -> pure Nothing (IdentityTermRenderer, _) -> Just <$> parse syntaxParser blobSource where syntaxParser = parserForLanguage blobLanguage From 0b497fb8a23bb8e82d890a9a41c1f180c585f554 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 20 Jul 2017 11:06:14 -0400 Subject: [PATCH 09/11] Remove JSON from ToCTermRenderer since it doesn't have functions --- src/Semantic.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index 22c370157..5bed51672 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -45,7 +45,6 @@ parseBlob :: TermRenderer output -> Blob -> Task output parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) (ToCTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) - (ToCTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) (ToCTermRenderer, _) -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource) >>= render (renderToCTerm blob) (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) (JSONTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) From f7a7a2c18037cf120d71ad7e5f88690cdb8457e8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 20 Jul 2017 11:12:08 -0400 Subject: [PATCH 10/11] Add parseError to value Assignment in the JSON parser --- src/Language/JSON/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/JSON/Syntax.hs b/src/Language/JSON/Syntax.hs index fa207365e..ebc8800de 100644 --- a/src/Language/JSON/Syntax.hs +++ b/src/Language/JSON/Syntax.hs @@ -44,7 +44,7 @@ assignment :: Assignment assignment = object <|> array <|> parseError value :: Assignment -value = object <|> array <|> number <|> string <|> boolean <|> none +value = object <|> array <|> number <|> string <|> boolean <|> none <|> parseError object :: Assignment object = makeTerm <$> symbol Object <*> children (Literal.Hash <$> many pairs) From de2146a1cdb904c8de6d57add61f5ecea40179cb Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 20 Jul 2017 12:35:34 -0400 Subject: [PATCH 11/11] Merge 'master' into json --- semantic-diff.cabal | 4 +- src/Arguments.hs | 40 ----------------- src/Command.hs | 5 --- src/Data/Syntax/Assignment.hs | 9 ++-- src/{Command => }/Files.hs | 5 +-- src/Language.hs | 2 +- src/Parser.hs | 31 ++++++------- src/Renderer.hs | 9 ++++ src/Renderer/TOC.hs | 67 +++++++++++++-------------- src/Semantic.hs | 37 ++++++++------- src/Semantic/Task.hs | 36 ++++++++++++--- src/SemanticCmdLine.hs | 85 ++++++++++++++--------------------- test/CommandSpec.hs | 2 +- test/SemanticCmdLineSpec.hs | 48 +++++++++----------- test/TOCSpec.hs | 20 ++++----- 15 files changed, 180 insertions(+), 220 deletions(-) delete mode 100644 src/Arguments.hs delete mode 100644 src/Command.hs rename src/{Command => }/Files.hs (96%) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index bdce25e6f..df043eb8b 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -15,10 +15,7 @@ library hs-source-dirs: src exposed-modules: Algorithm , Alignment - , Arguments , Category - , Command - , Command.Files , Data.Align.Generic , Data.Blob , Data.Functor.Both @@ -44,6 +41,7 @@ library , Data.Text.Listable , Decorators , Diff + , Files , Info , Interpreter , Language diff --git a/src/Arguments.hs b/src/Arguments.hs deleted file mode 100644 index a963d6def..000000000 --- a/src/Arguments.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE GADTs, DuplicateRecordFields, RankNTypes, StandaloneDeriving, UndecidableInstances #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Arguments where - -import Data.Maybe -import Language -import Prologue -import Renderer - -data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) - deriving Show - -data DiffArguments where - DiffArguments :: (Monoid output, StringConv output ByteString) => - { diffRenderer :: DiffRenderer output - , diffMode :: DiffMode - } -> DiffArguments - -deriving instance Show DiffArguments - - -data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] - deriving Show - -data ParseArguments where - ParseArguments :: (Monoid output, StringConv output ByteString) => - { parseTreeRenderer :: TermRenderer output - , parseMode :: ParseMode - } -> ParseArguments - -deriving instance Show ParseArguments - - -data ProgramMode = Parse ParseArguments | Diff DiffArguments - deriving Show - -data Arguments = Arguments - { programMode :: ProgramMode - , outputFilePath :: Maybe FilePath - } deriving Show diff --git a/src/Command.hs b/src/Command.hs deleted file mode 100644 index 8fcbcd26e..000000000 --- a/src/Command.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Command -( module Files -) where - -import Command.Files as Files diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9373a91e0..4044052a5 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -88,6 +88,7 @@ module Data.Syntax.Assignment ) where import Control.Monad.Free.Freer +import Data.Blob import Data.ByteString (isSuffixOf) import Data.Functor.Classes import Data.Functor.Foldable as F hiding (Nil) @@ -187,14 +188,14 @@ data ErrorCause grammar deriving (Eq, Show) -- | Pretty-print an Error with reference to the source where it occurred. -printError :: Show grammar => Source.Source -> Error grammar -> IO () -printError source error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos Nothing errorPos . showString ": " +printError :: Show grammar => Blob -> Error grammar -> IO () +printError Blob{..} error@Error{..} = do + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": " withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n' putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n' putStrErr $ showString (prettyCallStack callStack) . showChar '\n' - where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines source), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) + where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double))) putStrErr = hPutStr stderr . ($ "") diff --git a/src/Command/Files.hs b/src/Files.hs similarity index 96% rename from src/Command/Files.hs rename to src/Files.hs index 848efe380..874e5ee08 100644 --- a/src/Command/Files.hs +++ b/src/Files.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} -module Command.Files +module Files ( readFile , readBlobPairsFromHandle , readBlobsFromHandle @@ -20,8 +20,7 @@ import qualified Data.ByteString.Lazy as BL import Prelude (fail) import System.FilePath - --- | Read a file to a Blob, transcoding to UTF-8 along the way. +-- | Read a utf8-encoded file to a 'Blob'. readFile :: FilePath -> Maybe Language -> IO Blob.Blob readFile path language = do raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) diff --git a/src/Language.hs b/src/Language.hs index a70fb9480..e819e4e21 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -19,7 +19,7 @@ data Language = | Python | Ruby | TypeScript - deriving (Show, Eq, Read, Generic, ToJSON) + deriving (Show, Eq, Read, Generic, NFData, ToJSON) -- | Returns a Language based on the file extension (including the "."). languageForType :: String -> Maybe Language diff --git a/src/Parser.hs b/src/Parser.hs index e3312ce05..658958b03 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -12,6 +12,7 @@ module Parser ) where import qualified CMark +import Data.Blob import Data.Functor.Foldable hiding (fold, Nil) import Data.Record import Data.Source as Source @@ -44,10 +45,10 @@ data Parser term where ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST grammar) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. Assignment errors will result in a top-level 'Syntax.Error' node. AssignmentParser :: (Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs), Recursive ast, Foldable (Base ast)) - => Parser ast -- ^ A parser producing AST. - -> (forall x. Base ast x -> Node grammar) -- ^ A function extracting the symbol and location. - -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. - -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. + => Parser ast -- ^ A parser producing AST. + -> (forall x. Base ast x -> Node grammar) -- ^ A function extracting the symbol and location. + -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. + -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. -- | A tree-sitter parser. TreeSitterParser :: Language -> Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields) -- | A parser for 'Markdown' using cmark. @@ -79,19 +80,19 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) headF JSON.assignment markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment -runParser :: Parser term -> Source -> IO term -runParser parser = case parser of - ASTParser language -> parseToAST language - AssignmentParser parser by assignment -> \ source -> do - ast <- runParser parser source - case assignBy by assignment source ast of +runParser :: Parser term -> Blob -> IO term +runParser parser blob@Blob{..} = case parser of + ASTParser language -> parseToAST language blobSource + AssignmentParser parser by assignment -> do + ast <- runParser parser blob + case assignBy by assignment blobSource ast of Left err -> do - printError source err - pure (errorTerm source) + printError blob err + pure (errorTerm blobSource) Right term -> pure term - TreeSitterParser language tslanguage -> treeSitterParser language tslanguage - MarkdownParser -> pure . cmarkParser - LineByLineParser -> pure . lineByLineParser + TreeSitterParser language tslanguage -> treeSitterParser language tslanguage blobSource + MarkdownParser -> pure (cmarkParser blobSource) + LineByLineParser -> pure (lineByLineParser blobSource) errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Location) errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error [])) diff --git a/src/Renderer.hs b/src/Renderer.hs index 10a35a672..24c233840 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -2,6 +2,7 @@ module Renderer ( DiffRenderer(..) , TermRenderer(..) +, SomeRenderer(..) , renderPatch , renderSExpressionDiff , renderSExpressionTerm @@ -61,6 +62,14 @@ deriving instance Eq (TermRenderer output) deriving instance Show (TermRenderer output) +-- | Abstraction of some renderer to some 'Monoid'al output which can be serialized to a 'ByteString'. +-- +-- This type abstracts the type indices of 'DiffRenderer' and 'TermRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.) +data SomeRenderer f where + SomeRenderer :: (Monoid output, StringConv output ByteString, Show (f output)) => f output -> SomeRenderer f + +deriving instance Show (SomeRenderer f) + identifierAlgebra :: RAlgebra (CofreeF (Syntax Text) a) (Cofree (Syntax Text) a) (Maybe Identifier) identifierAlgebra (_ :< syntax) = case syntax of S.Assignment f _ -> identifier f diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 9c249cf04..62f5eb626 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -81,7 +81,7 @@ data Declaration = MethodDeclaration { declarationIdentifier :: Text } | FunctionDeclaration { declarationIdentifier :: Text } | SectionDeclaration { declarationIdentifier :: Text, declarationLevel :: Int } - | ErrorDeclaration { declarationIdentifier :: Text } + | ErrorDeclaration { declarationIdentifier :: Text, declarationLanguage :: Maybe Language } deriving (Eq, Generic, NFData, Show) getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration @@ -93,38 +93,38 @@ declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Decl -- | Compute 'Declaration's for methods and functions in 'Syntax'. -syntaxDeclarationAlgebra :: HasField fields Range => Source -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration) -syntaxDeclarationAlgebra source r = case tailF r of +syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration) +syntaxDeclarationAlgebra Blob{..} r = case tailF r of S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) S.Method _ (identifier, _) (Just (receiver, _)) _ _ | S.Indexed [receiverParams] <- unwrap receiver , S.ParameterDecl (Just ty) _ <- unwrap receiverParams -> Just $ MethodDeclaration ("(" <> getSource ty <> ") " <> getSource identifier) | otherwise -> Just $ MethodDeclaration (getSource receiver <> "." <> getSource identifier) - S.ParseError{} -> Just $ ErrorDeclaration (toText (Source.slice (byteRange (headF r)) source)) + S.ParseError{} -> Just $ ErrorDeclaration (toText (Source.slice (byteRange (headF r)) blobSource)) blobLanguage _ -> Nothing - where getSource = toText . flip Source.slice source . byteRange . extract + where getSource = toText . flip Source.slice blobSource . byteRange . extract -- | Compute 'Declaration's for methods and functions. declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Functor (Union fs), HasField fields Range) - => Source + => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -declarationAlgebra source r +declarationAlgebra Blob{..} r | Just (Declaration.Function (identifier, _) _ _) <- prj (tailF r) = Just $ FunctionDeclaration (getSource (extract identifier)) | Just (Declaration.Method _ (identifier, _) _ _) <- prj (tailF r) = Just $ MethodDeclaration (getSource (extract identifier)) - | Just Syntax.Error{} <- prj (tailF r) = Just $ ErrorDeclaration (getSource (headF r)) + | Just Syntax.Error{} <- prj (tailF r) = Just $ ErrorDeclaration (getSource (headF r)) blobLanguage | otherwise = Nothing - where getSource = toText . flip Source.slice source . byteRange + where getSource = toText . flip Source.slice blobSource . byteRange -- | Compute 'Declaration's with the headings of 'Markup.Section's. markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, Functor (Union fs), Foldable (Union fs)) - => Source + => Blob -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) -markupSectionAlgebra source r - | Just (Markup.Section level (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice source . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level - | Just Syntax.Error{} <- prj (tailF r) = Just $ ErrorDeclaration (getSource (headF r)) +markupSectionAlgebra Blob{..} r + | Just (Markup.Section level (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level + | Just Syntax.Error{} <- prj (tailF r) = Just $ ErrorDeclaration (getSource (headF r)) blobLanguage | otherwise = Nothing - where getSource = firstLine . toText . flip Source.slice source . byteRange + where getSource = firstLine . toText . flip Source.slice blobSource . byteRange firstLine = T.takeWhile (/= '\n') @@ -172,30 +172,25 @@ dedupe = foldl' go [] similarDeclaration = (==) `on` fmap (toLower . declarationIdentifier) . getDeclaration -- | Construct a 'JSONSummary' from an 'Entry'. Returns 'Nothing' for 'Unchanged' patches. -entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Maybe Language -> Entry (Record fields) -> Maybe JSONSummary -entrySummary language entry = case entry of +entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Entry (Record fields) -> Maybe JSONSummary +entrySummary entry = case entry of Unchanged _ -> Nothing - Changed a -> recordSummary language a "modified" - Deleted a -> recordSummary language a "removed" - Inserted a -> recordSummary language a "added" - Replaced a -> recordSummary language a "modified" + Changed a -> recordSummary a "modified" + Deleted a -> recordSummary a "removed" + Inserted a -> recordSummary a "added" + Replaced a -> recordSummary a "modified" -- | Construct a 'JSONSummary' from a node annotation and a change type label. -recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Maybe Language -> Record fields -> Text -> Maybe JSONSummary -recordSummary language record = case getDeclaration record of - Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record) language) +recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Record fields -> Text -> Maybe JSONSummary +recordSummary record = case getDeclaration record of + Just (ErrorDeclaration text language) -> Just . const (ErrorSummary text (sourceSpan record) language) Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record) Nothing -> const Nothing renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Both Blob -> Diff f (Record fields) -> Summaries -renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC language +renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where toMap [] = mempty toMap as = Map.singleton summaryKey (toJSON <$> as) - language = case runJoin (blobLanguage <$> blobs) of - (Nothing, Just after) -> Just after - (Just before, Nothing) -> Just before - (Nothing, Nothing) -> Nothing - (Just before, Just _) -> Just before summaryKey = toS $ case runJoin (blobPath <$> blobs) of (before, after) | null before -> after | null after -> before @@ -203,15 +198,15 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV | otherwise -> before <> " -> " <> after renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Blob -> Term f (Record fields) -> Summaries -renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC blobLanguage +renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC where toMap [] = mempty toMap as = Map.singleton (toS blobPath) (toJSON <$> as) -diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Maybe Language -> Diff f (Record fields) -> [JSONSummary] -diffTOC language = mapMaybe (entrySummary language) . dedupe . tableOfContentsBy declaration +diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Diff f (Record fields) -> [JSONSummary] +diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration -termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Maybe Language -> Term f (Record fields) -> [JSONSummary] -termToC language = mapMaybe (flip (recordSummary language) "unchanged") . termTableOfContentsBy declaration +termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Traversable f) => Term f (Record fields) -> [JSONSummary] +termToC = mapMaybe (flip recordSummary "unchanged") . termTableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> Text @@ -219,10 +214,10 @@ toCategoryName declaration = case declaration of FunctionDeclaration _ -> "Function" MethodDeclaration _ -> "Method" SectionDeclaration _ l -> "Heading " <> show l - ErrorDeclaration _ -> "ParseError" + ErrorDeclaration{} -> "ParseError" instance Listable Declaration where tiers = cons1 (MethodDeclaration . unListableText) \/ cons1 (FunctionDeclaration . unListableText) - \/ cons1 (ErrorDeclaration . unListableText) + \/ cons1 (flip ErrorDeclaration Nothing . unListableText) diff --git a/src/Semantic.hs b/src/Semantic.hs index 5bed51672..867cd461f 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -13,7 +13,6 @@ import Data.Blob import Data.Functor.Both as Both import Data.Functor.Classes (Eq1, Show1) import Data.Record -import Data.Source import qualified Data.Syntax.Declaration as Declaration import Data.Union import Decorators @@ -43,21 +42,21 @@ parseBlobs renderer = fmap toS . distributeFoldMap (parseBlob renderer) . filter -- | A task to parse a 'Blob' and render the resulting 'Term'. parseBlob :: TermRenderer output -> Blob -> Task output parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of - (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) - (ToCTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) - (ToCTermRenderer, _) -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource) >>= render (renderToCTerm blob) - (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) - (JSONTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) - (JSONTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate constructorLabel >>= render (renderJSONTerm blob) - (JSONTermRenderer, _) -> parse syntaxParser blobSource >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) - (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel - (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel - (SExpressionTermRenderer, Just Language.JSON) -> parse jsonParser blobSource >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel - (SExpressionTermRenderer, _) -> parse syntaxParser blobSource >>= render renderSExpressionTerm . fmap keepCategory + (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate (markupSectionAlgebra blob) >>= render (renderToCTerm blob) + (ToCTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) + (ToCTermRenderer, _) -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob) >>= render (renderToCTerm blob) + (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) + (JSONTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) + (JSONTermRenderer, Just Language.JSON) -> parse jsonParser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob) + (JSONTermRenderer, _) -> parse syntaxParser blob >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) + (SExpressionTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, Just Language.JSON) -> parse jsonParser blob >>= decorate constructorLabel >>= render renderSExpressionTerm . fmap keepConstructorLabel + (SExpressionTermRenderer, _) -> parse syntaxParser blob >>= render renderSExpressionTerm . fmap keepCategory (IdentityTermRenderer, Just Language.Markdown) -> pure Nothing (IdentityTermRenderer, Just Language.Python) -> pure Nothing (IdentityTermRenderer, Just Language.JSON) -> pure Nothing - (IdentityTermRenderer, _) -> Just <$> parse syntaxParser blobSource + (IdentityTermRenderer, _) -> Just <$> parse syntaxParser blob where syntaxParser = parserForLanguage blobLanguage @@ -68,9 +67,9 @@ diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) . -- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'. diffBlobPair :: DiffRenderer output -> Both Blob -> Task output diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of - (ToCDiffRenderer, Just Language.Markdown) -> run (\ blobSource -> parse markdownParser blobSource >>= decorate (markupSectionAlgebra blobSource)) diffLinearly (renderToCDiff blobs) - (ToCDiffRenderer, Just Language.Python) -> run (\ blobSource -> parse pythonParser blobSource >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs) - (ToCDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms (renderToCDiff blobs) + (ToCDiffRenderer, Just Language.Markdown) -> run (\ blob -> parse markdownParser blob >>= decorate (markupSectionAlgebra blob)) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, Just Language.Python) -> run (\ blob -> parse pythonParser blob >>= decorate (declarationAlgebra blob) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms (renderToCDiff blobs) (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, Just Language.JSON) -> run (parse jsonParser) diffLinearly (renderJSONDiff blobs) @@ -83,12 +82,12 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffLinearly (renderSExpressionDiff . mapAnnotations keepConstructorLabel) (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory) - (IdentityDiffRenderer, _) -> run (\ blobSource -> parse syntaxParser blobSource >>= decorate (syntaxDeclarationAlgebra blobSource)) diffTerms Just + (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) syntaxParser = parserForLanguage effectiveLanguage - run :: Functor f => (Source -> Task (Term f a)) -> (Both (Term f a) -> Diff f a) -> (Diff f a -> output) -> Task output - run parse diff renderer = distributeFor blobs (parse . blobSource) >>= diffTermPair blobs diff >>= render renderer + run :: Functor f => (Blob -> Task (Term f a)) -> (Both (Term f a) -> Diff f a) -> (Diff f a -> output) -> Task output + run parse diff renderer = distributeFor blobs parse >>= diffTermPair blobs diff >>= render renderer diffLinearly :: (Eq1 f, GAlign f, Show1 f, Traversable f) => Both (Term f (Record fields)) -> Diff f (Record fields) diffLinearly = decoratingWith constructorNameAndConstantFields (diffTermsWith linearly comparableByConstructor) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index d80abbd3d..d32f37142 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -3,6 +3,9 @@ module Semantic.Task ( Task , RAlgebra , Differ +, readBlobs +, readBlobPairs +, writeToOutput , parse , decorate , diff @@ -13,20 +16,26 @@ module Semantic.Task , runTask ) where +import qualified Files import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer +import Data.Blob +import qualified Data.ByteString as B import Data.Functor.Both as Both import Data.Record -import Data.Source import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import Diff +import Language import Parser import Prologue import Term data TaskF output where - Parse :: Parser term -> Source -> TaskF term + ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] + ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] + WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF () + Parse :: Parser term -> Blob -> TaskF term Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields))) Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a) Render :: Renderer input output -> input -> TaskF output @@ -41,10 +50,22 @@ type Differ f a = Both (Term f a) -> Diff f a -- | A function to render terms or diffs. type Renderer i o = i -> o +-- | A 'Task' which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. +readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob] +readBlobs from = ReadBlobs from `Then` return --- | A 'Task' which parses 'Source' with the given 'Parser'. -parse :: Parser term -> Source -> Task term -parse parser source = Parse parser source `Then` return +-- | A 'Task' which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. +readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob] +readBlobPairs from = ReadBlobPairs from `Then` return + +-- | A 'Task' which writes a 'ByteString' to a 'Handle' or a 'FilePath'. +writeToOutput :: Either Handle FilePath -> ByteString -> Task () +writeToOutput path contents = WriteToOutput path contents `Then` return + + +-- | A 'Task' which parses a 'Blob' with the given 'Parser'. +parse :: Parser term -> Blob -> Task term +parse parser blob = Parse parser blob `Then` return -- | A 'Task' which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields))) @@ -80,7 +101,10 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Execute a 'Task', yielding its result value in 'IO'. runTask :: Task a -> IO a runTask = iterFreerA $ \ task yield -> case task of - Parse parser source -> runParser parser source >>= yield + ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield + ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield + WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield + Parse parser blob -> runParser parser blob >>= yield Decorate algebra term -> yield (decoratorWithAlgebra algebra term) Diff differ terms -> yield (differ terms) Render renderer input -> yield (renderer input) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d0d7b59ff..01cfa3edb 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -1,84 +1,67 @@ {-# LANGUAGE TemplateHaskell #-} -module SemanticCmdLine (main, runDiff, runParse) where +module SemanticCmdLine +( main +-- Testing +, runDiff +, runParse +) where -import Arguments -import Command -import Command.Files (languageForFilePath) +import Files (languageForFilePath) import Data.Functor.Both import Data.List.Split (splitWhen) import Data.Version (showVersion) import Development.GitRev +import Language import Options.Applicative hiding (action) import Prologue hiding (concurrently, fst, snd, readFile) import Renderer -import qualified Data.ByteString as B import qualified Paths_semantic_diff as Library (version) import qualified Semantic.Task as Task -import System.Directory -import System.FilePath.Posix (takeFileName, (-<.>)) import System.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () -main = do - Arguments{..} <- customExecParser (prefs showHelpOnEmpty) arguments - outputPath <- traverse getOutputPath outputFilePath - text <- case programMode of - Diff args -> runDiff args - Parse args -> runParse args - writeToOutput outputPath text - where - getOutputPath path = do - isDir <- doesDirectoryExist path - pure $ if isDir then takeFileName path -<.> ".html" else path - writeToOutput :: Maybe FilePath -> ByteString -> IO () - writeToOutput = maybe B.putStr B.writeFile +main = customExecParser (prefs showHelpOnEmpty) arguments >>= Task.runTask -runDiff :: DiffArguments -> IO ByteString -runDiff DiffArguments{..} = do - blobs <- case diffMode of - DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b) - DiffStdin -> readBlobPairsFromHandle stdin - Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) +runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString +runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs -runParse :: ParseArguments -> IO ByteString -runParse ParseArguments{..} = do - blobs <- case parseMode of - ParsePaths paths -> traverse (uncurry readFile) paths - ParseStdin -> readBlobsFromHandle stdin - Task.runTask (Semantic.parseBlobs parseTreeRenderer blobs) +runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString +runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -- | A parser for the application's command-line arguments. -arguments :: ParserInfo Arguments +-- +-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout. +arguments :: ParserInfo (Task.Task ()) arguments = info (version <*> helper <*> argumentsParser) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - argumentsParser = Arguments + argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) - <*> optional (strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")) + <*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") + <|> pure (Left stdout) ) diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths")) - diffArgumentsParser = Diff - <$> ( ( flag (DiffArguments PatchDiffRenderer) (DiffArguments PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)") - <|> flag' (DiffArguments JSONDiffRenderer) (long "json" <> help "Output a json diff") - <|> flag' (DiffArguments SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree") - <|> flag' (DiffArguments ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") ) - <*> ( DiffPaths - <$> argument filePathReader (metavar "FILE_A") - <*> argument filePathReader (metavar "FILE_B") - <|> pure DiffStdin )) + diffArgumentsParser = runDiff + <$> ( flag (SomeRenderer PatchDiffRenderer) (SomeRenderer PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)") + <|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output a json diff") + <|> flag' (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree") + <|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") ) + <*> ( ((Right . pure) .) . both + <$> argument filePathReader (metavar "FILE_A") + <*> argument filePathReader (metavar "FILE_B") + <|> pure (Left stdin) ) parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)")) - parseArgumentsParser = Parse - <$> ( ( flag (ParseArguments SExpressionTermRenderer) (ParseArguments SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") - <|> flag' (ParseArguments JSONTermRenderer) (long "json" <> help "Output JSON parse trees") - <|> flag' (ParseArguments ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file")) - <*> ( ParsePaths - <$> some (argument filePathReader (metavar "FILES...")) - <|> pure ParseStdin )) + parseArgumentsParser = runParse + <$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") + <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees") + <|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file")) + <*> ( Right <$> some (argument filePathReader (metavar "FILES...")) + <|> pure (Left stdin) ) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs index 7922a547b..3a81d9ba1 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -1,6 +1,6 @@ module CommandSpec where -import Command +import Files import Data.Blob import Data.Functor.Both as Both import Data.Maybe diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 6991faa81..c2b7f346f 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DuplicateRecordFields #-} module SemanticCmdLineSpec where -import Prologue -import Arguments +import Data.Functor.Both import Language +import Prologue import Renderer +import Semantic.Task import SemanticCmdLine import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty @@ -12,32 +13,32 @@ import Test.Hspec.Expectations.Pretty spec :: Spec spec = parallel $ do describe "runDiff" $ - for_ diffFixtures $ \ (arguments@DiffArguments{..}, expected) -> + for_ diffFixtures $ \ (diffRenderer, diffMode, expected) -> it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do - output <- runDiff arguments + output <- runTask $ runDiff diffRenderer diffMode output `shouldBe'` expected describe "runParse" $ - for_ parseFixtures $ \ (arguments@ParseArguments{..}, expected) -> + for_ parseFixtures $ \ (parseTreeRenderer, parseMode, expected) -> it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do - output <- runParse arguments + output <- runTask $ runParse parseTreeRenderer parseMode output `shouldBe'` expected where shouldBe' actual expected = do when (actual /= expected) $ print actual actual `shouldBe` expected -parseFixtures :: [(ParseArguments, ByteString)] +parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)] parseFixtures = - [ (ParseArguments SExpressionTermRenderer pathMode, sExpressionParseTreeOutput) - , (ParseArguments JSONTermRenderer pathMode, jsonParseTreeOutput) - , (ParseArguments JSONTermRenderer pathMode', jsonParseTreeOutput') - , (ParseArguments JSONTermRenderer (ParsePaths []), emptyJsonParseTreeOutput) - , (ParseArguments JSONTermRenderer (ParsePaths [("not-a-file.rb", Just Ruby)]), emptyJsonParseTreeOutput) - , (ParseArguments ToCTermRenderer (ParsePaths [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)]), tocOutput) + [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput) + , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) + , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') + , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput) + , (SomeRenderer JSONTermRenderer, Right [("not-a-file.rb", Just Ruby)], emptyJsonParseTreeOutput) + , (SomeRenderer ToCTermRenderer, Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tocOutput) ] - where pathMode = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby)] - pathMode' = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)] + where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)] + pathMode' = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)] sExpressionParseTreeOutput = "(Program\n (Binary\n (Identifier)\n (Other \"and\")\n (Identifier)))\n" jsonParseTreeOutput = "[{\"filePath\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]\n" @@ -46,19 +47,14 @@ parseFixtures = tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"unchanged\"}]},\"errors\":{}}\n" -data DiffFixture = DiffFixture - { arguments :: DiffArguments - , expected :: ByteString - } deriving (Show) - -diffFixtures :: [(DiffArguments, ByteString)] +diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)] diffFixtures = - [ (DiffArguments PatchDiffRenderer pathMode, patchOutput) - , (DiffArguments JSONDiffRenderer pathMode, jsonOutput) - , (DiffArguments SExpressionDiffRenderer pathMode, sExpressionOutput) - , (DiffArguments ToCDiffRenderer pathMode, tocOutput) + [ (SomeRenderer PatchDiffRenderer, pathMode, patchOutput) + , (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput) + , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput) + , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput) ] - where pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby) + where pathMode = Right [both ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)] patchOutput = "diff --git a/test/fixtures/ruby/method-declaration.A.rb b/test/fixtures/ruby/method-declaration.B.rb\nindex 0000000000000000000000000000000000000000..0000000000000000000000000000000000000000 100644\n--- a/test/fixtures/ruby/method-declaration.A.rb\n+++ b/test/fixtures/ruby/method-declaration.B.rb\n@@ -1,3 +1,4 @@\n-def foo\n+def bar(a)\n+ baz\n end\n\n" diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index e270b948e..90c9b6292 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -55,12 +55,12 @@ spec = parallel $ do describe "diffTOC" $ do it "blank if there are no methods" $ - diffTOC Nothing blankDiff `shouldBe` [ ] + diffTOC blankDiff `shouldBe` [ ] it "summarizes changed methods" $ do sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just Ruby) diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Method" "self.foo" (sourceSpanBetween (1, 1) (2, 4)) "added" , JSONSummary "Method" "bar" (sourceSpanBetween (4, 1) (6, 4)) "modified" , JSONSummary "Method" "baz" (sourceSpanBetween (4, 1) (5, 4)) "removed" ] @@ -68,37 +68,37 @@ spec = parallel $ do it "dedupes changes in same parent method" $ do sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC Nothing diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Function" "myFunction" (sourceSpanBetween (1, 1) (6, 2)) "modified" ] it "dedupes similar methods" $ do sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just JavaScript) diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Function" "performHealthCheck" (sourceSpanBetween (8, 1) (29, 2)) "modified" ] it "summarizes Go methods with receivers with special formatting" $ do sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just Language.Go) diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Method" "(*apiClient) CheckAuth" (sourceSpanBetween (3,1) (3,101)) "added" ] it "summarizes Ruby methods that start with two identifiers" $ do sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just Ruby) diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Method" "foo" (sourceSpanBetween (1, 1) (4, 4)) "modified" ] it "handles unicode characters in file" $ do sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just Ruby) diff `shouldBe` + diffTOC diff `shouldBe` [ JSONSummary "Method" "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (both "javascript/starts-with-newline.js" "javascript/starts-with-newline.js") Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) - diffTOC (Just JavaScript) diff `shouldBe` [] + diffTOC diff `shouldBe` [] prop "inserts of methods and functions are summarized" $ \name body -> @@ -127,7 +127,7 @@ spec = parallel $ do prop "equal terms produce identity diffs" $ \a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in - diffTOC Nothing (diffTerms (pure term)) `shouldBe` [] + diffTOC (diffTerms (pure term)) `shouldBe` [] describe "JSONSummary" $ do it "encodes modified summaries to JSON" $ do @@ -159,7 +159,7 @@ type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields) type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields) numTocSummaries :: Diff' -> Int -numTocSummaries diff = length $ filter isValidSummary (diffTOC Nothing diff) +numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) -- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff. programWithChange :: Term' -> Diff'