From 0722f0962698576b749cec7a2dc7ed4e12c66630 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 13:54:48 -0400 Subject: [PATCH 01/49] Define a SomeRenderer type to abstract type indices away. --- src/Renderer.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Renderer.hs b/src/Renderer.hs index 10a35a672..32f8a8302 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -61,6 +61,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 From 5ea5b7fb05c9e596014a28ef0714ad0976fbee4a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 13:59:20 -0400 Subject: [PATCH 02/49] Export SomeRenderer. --- src/Renderer.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Renderer.hs b/src/Renderer.hs index 32f8a8302..24c233840 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -2,6 +2,7 @@ module Renderer ( DiffRenderer(..) , TermRenderer(..) +, SomeRenderer(..) , renderPatch , renderSExpressionDiff , renderSExpressionTerm From e03ba6b0e47cb4a1c574a813e54c9bedb116f1c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:00:30 -0400 Subject: [PATCH 03/49] Define diffing/parsing CLI parsers in terms of SomeRenderer and the action to be performed. --- src/SemanticCmdLine.hs | 52 +++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d0d7b59ff..d909cd0ac 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -21,11 +21,9 @@ import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () main = do - Arguments{..} <- customExecParser (prefs showHelpOnEmpty) arguments + (command, outputFilePath) <- customExecParser (prefs showHelpOnEmpty) arguments outputPath <- traverse getOutputPath outputFilePath - text <- case programMode of - Diff args -> runDiff args - Parse args -> runParse args + text <- command writeToOutput outputPath text where getOutputPath path = do @@ -34,51 +32,53 @@ main = do writeToOutput :: Maybe FilePath -> ByteString -> IO () writeToOutput = maybe B.putStr B.writeFile -runDiff :: DiffArguments -> IO ByteString -runDiff DiffArguments{..} = do +runDiff :: SomeRenderer DiffRenderer -> DiffMode -> IO ByteString +runDiff (SomeRenderer diffRenderer) diffMode = do blobs <- case diffMode of DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b) DiffStdin -> readBlobPairsFromHandle stdin Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) -runParse :: ParseArguments -> IO ByteString -runParse ParseArguments{..} = do +runParse :: SomeRenderer TermRenderer -> ParseMode -> IO ByteString +runParse (SomeRenderer parseTreeRenderer) parseMode = do blobs <- case parseMode of ParsePaths paths -> traverse (uncurry readFile) paths ParseStdin -> readBlobsFromHandle stdin Task.runTask (Semantic.parseBlobs parseTreeRenderer blobs) -- | A parser for the application's command-line arguments. -arguments :: ParserInfo Arguments +-- +-- Returns an 'IO' action producing 'ByteString' output, and a 'Maybe FilePath' to write the output to. +arguments :: ParserInfo (IO ByteString, Maybe FilePath) 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 = (,) <$> hsubparser (diffCommand <> parseCommand) <*> optional (strOption (long "output" <> short 'o' <> help "Output path, defaults to 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") ) + <*> ( DiffPaths + <$> argument filePathReader (metavar "FILE_A") + <*> argument filePathReader (metavar "FILE_B") + <|> pure DiffStdin ) 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")) + <*> ( ParsePaths + <$> some (argument filePathReader (metavar "FILES...")) + <|> pure ParseStdin ) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of From 9d4737048d5789871fe025738ffa569327f652b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:01:56 -0400 Subject: [PATCH 04/49] Correct the specs. --- test/SemanticCmdLineSpec.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 6991faa81..43e322b89 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -12,29 +12,29 @@ 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 <- 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 <- 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, ParseMode, 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, ParsePaths [], emptyJsonParseTreeOutput) + , (SomeRenderer JSONTermRenderer, ParsePaths [("not-a-file.rb", Just Ruby)], emptyJsonParseTreeOutput) + , (SomeRenderer ToCTermRenderer, ParsePaths [("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)] @@ -51,12 +51,12 @@ data DiffFixture = DiffFixture , expected :: ByteString } deriving (Show) -diffFixtures :: [(DiffArguments, ByteString)] +diffFixtures :: [(SomeRenderer DiffRenderer, DiffMode, 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) From 1a3708a4627a7f67440be9a89720c32dff0a3912 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:02:22 -0400 Subject: [PATCH 05/49] Format the export list. --- src/SemanticCmdLine.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d909cd0ac..f39f8cffb 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -1,5 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -module SemanticCmdLine (main, runDiff, runParse) where +module SemanticCmdLine +( main +-- Testing +, runDiff +, runParse +) where import Arguments import Command From 5e13616358dd5adcfcdba98854e64ee79abeea3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:03:51 -0400 Subject: [PATCH 06/49] :fire: Arguments. --- src/Arguments.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index a963d6def..9282c00ce 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -33,8 +33,3 @@ deriving instance Show ParseArguments data ProgramMode = Parse ParseArguments | Diff DiffArguments deriving Show - -data Arguments = Arguments - { programMode :: ProgramMode - , outputFilePath :: Maybe FilePath - } deriving Show From 30d4c6a6e873746c3a41f69b8d18414b4640beea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:04:17 -0400 Subject: [PATCH 07/49] :fire: ProgramMode. --- src/Arguments.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index 9282c00ce..bb4a57c93 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -29,7 +29,3 @@ data ParseArguments where } -> ParseArguments deriving instance Show ParseArguments - - -data ProgramMode = Parse ParseArguments | Diff DiffArguments - deriving Show From b74cc92213350655f8d45be8f58942572bda3cc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:04:33 -0400 Subject: [PATCH 08/49] :fire: ParseArguments. --- src/Arguments.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index bb4a57c93..4803f5b00 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -21,11 +21,3 @@ 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 From 2cd59243a0ae04066131b725a21fb453f8a70b92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:04:39 -0400 Subject: [PATCH 09/49] :fire: DiffArguments. --- src/Arguments.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index 4803f5b00..0adb817cf 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -10,14 +10,6 @@ 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 From 4df9192d02f6367955709ac72b8c0d36e9bcab82 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:05:23 -0400 Subject: [PATCH 10/49] Move ParseMode into SemanticCmdLine. --- src/Arguments.hs | 4 ---- src/SemanticCmdLine.hs | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index 0adb817cf..a0040c5ef 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -9,7 +9,3 @@ import Renderer data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) deriving Show - - -data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] - deriving Show diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index f39f8cffb..348dbdee3 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -3,6 +3,7 @@ module SemanticCmdLine ( main -- Testing , runDiff +, ParseMode , runParse ) where @@ -13,6 +14,7 @@ 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 @@ -44,6 +46,9 @@ runDiff (SomeRenderer diffRenderer) diffMode = do DiffStdin -> readBlobPairsFromHandle stdin Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) +data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] + deriving Show + runParse :: SomeRenderer TermRenderer -> ParseMode -> IO ByteString runParse (SomeRenderer parseTreeRenderer) parseMode = do blobs <- case parseMode of From be5de7acaf75eb27fec23b631ef8e96da027cfd0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:05:58 -0400 Subject: [PATCH 11/49] Move DiffMode into SemanticCmdLine. --- src/Arguments.hs | 3 --- src/SemanticCmdLine.hs | 5 ++++- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index a0040c5ef..63d0b7998 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -6,6 +6,3 @@ import Data.Maybe import Language import Prologue import Renderer - -data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) - deriving Show diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 348dbdee3..9f0f2a87b 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -2,12 +2,12 @@ module SemanticCmdLine ( main -- Testing +, DiffMode , runDiff , ParseMode , runParse ) where -import Arguments import Command import Command.Files (languageForFilePath) import Data.Functor.Both @@ -39,6 +39,9 @@ main = do writeToOutput :: Maybe FilePath -> ByteString -> IO () writeToOutput = maybe B.putStr B.writeFile +data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) + deriving Show + runDiff :: SomeRenderer DiffRenderer -> DiffMode -> IO ByteString runDiff (SomeRenderer diffRenderer) diffMode = do blobs <- case diffMode of From 7aa8ea115039ae942d7965a2c3299a216e356353 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:08:32 -0400 Subject: [PATCH 12/49] Export the DiffMode/ParseMode constructors. --- src/SemanticCmdLine.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 9f0f2a87b..49d99638a 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -2,9 +2,9 @@ module SemanticCmdLine ( main -- Testing -, DiffMode +, DiffMode(..) , runDiff -, ParseMode +, ParseMode(..) , runParse ) where From b630a11b6e49f36cd59be91dce8c4c710219433e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:08:38 -0400 Subject: [PATCH 13/49] :fire: Arguments. --- semantic-diff.cabal | 1 - src/Arguments.hs | 8 -------- 2 files changed, 9 deletions(-) delete mode 100644 src/Arguments.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 4b72a0fd5..e2b980637 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -15,7 +15,6 @@ library hs-source-dirs: src exposed-modules: Algorithm , Alignment - , Arguments , Category , Command , Command.Files diff --git a/src/Arguments.hs b/src/Arguments.hs deleted file mode 100644 index 63d0b7998..000000000 --- a/src/Arguments.hs +++ /dev/null @@ -1,8 +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 From 0b32ff0a3bb317e226d99d4926b40ba39337f739 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:09:11 -0400 Subject: [PATCH 14/49] :fire: DiffFixture. --- test/SemanticCmdLineSpec.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 43e322b89..cd5a7459c 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -46,11 +46,6 @@ 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 :: [(SomeRenderer DiffRenderer, DiffMode, ByteString)] diffFixtures = [ (SomeRenderer PatchDiffRenderer, pathMode, patchOutput) From 1fa7b11cc5b0f5e48bd672fe40e3b1df7fe87ae4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:09:19 -0400 Subject: [PATCH 15/49] :fire: the obsolete import of Arguments. --- test/SemanticCmdLineSpec.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index cd5a7459c..983068241 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -2,7 +2,6 @@ module SemanticCmdLineSpec where import Prologue -import Arguments import Language import Renderer import SemanticCmdLine From 1c51f23ef41d8af4fc7a97e736c5cb8d97181706 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:13:22 -0400 Subject: [PATCH 16/49] Import all the symbols from Command.Files instead of Command. --- src/SemanticCmdLine.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 49d99638a..e4e41c77a 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -8,8 +8,7 @@ module SemanticCmdLine , runParse ) where -import Command -import Command.Files (languageForFilePath) +import Command.Files (languageForFilePath, readBlobsFromHandle, readBlobPairsFromHandle, readFile) import Data.Functor.Both import Data.List.Split (splitWhen) import Data.Version (showVersion) From 5481883b9fb22a6dd858505abb0e69900a45c42b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:14:07 -0400 Subject: [PATCH 17/49] :fire: Command. --- semantic-diff.cabal | 1 - src/Command.hs | 5 ----- test/CommandSpec.hs | 2 +- 3 files changed, 1 insertion(+), 7 deletions(-) delete mode 100644 src/Command.hs diff --git a/semantic-diff.cabal b/semantic-diff.cabal index e2b980637..1ddd90e27 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -16,7 +16,6 @@ library exposed-modules: Algorithm , Alignment , Category - , Command , Command.Files , Data.Align.Generic , Data.Blob 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/test/CommandSpec.hs b/test/CommandSpec.hs index 7922a547b..061edc349 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -1,6 +1,6 @@ module CommandSpec where -import Command +import Command.Files import Data.Blob import Data.Functor.Both as Both import Data.Maybe From 6dd56e5bd9ef0fce012a89a19c67626ce5317899 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:42:02 -0400 Subject: [PATCH 18/49] Parse tasks take blobs. --- src/Semantic.hs | 33 ++++++++++++++++----------------- src/Semantic/Task.hs | 10 +++++----- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/src/Semantic.hs b/src/Semantic.hs index 95b6cb8f7..babcedc25 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,18 +42,18 @@ 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, _) -> 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, _) -> parse syntaxParser blobSource >>= render renderSExpressionTerm . fmap keepCategory + (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser blob >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) + (ToCTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) + (ToCTermRenderer, _) -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blobSource) >>= 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, _) -> 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, _) -> parse syntaxParser blob >>= render renderSExpressionTerm . fmap keepCategory (IdentityTermRenderer, Just Language.Markdown) -> pure Nothing (IdentityTermRenderer, Just Language.Python) -> pure Nothing - (IdentityTermRenderer, _) -> Just <$> parse syntaxParser blobSource + (IdentityTermRenderer, _) -> Just <$> parse syntaxParser blob where syntaxParser = parserForLanguage blobLanguage @@ -65,9 +64,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 (blobSource blob))) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, Just Language.Python) -> run (\ blob -> parse pythonParser blob >>= decorate (declarationAlgebra (blobSource blob)) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra (blobSource 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, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs) @@ -77,12 +76,12 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (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, _) -> 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 (blobSource 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..45600433a 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -16,9 +16,9 @@ module Semantic.Task import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer +import Data.Blob import Data.Functor.Both as Both import Data.Record -import Data.Source import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import Diff import Parser @@ -26,7 +26,7 @@ import Prologue import Term data TaskF output where - Parse :: Parser term -> Source -> TaskF term + 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 @@ -43,8 +43,8 @@ type Renderer i o = i -> o -- | A 'Task' which parses 'Source' with the given 'Parser'. -parse :: Parser term -> Source -> Task term -parse parser source = Parse parser source `Then` return +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 +80,7 @@ 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 + Parse parser blob -> runParser parser (blobSource blob) >>= yield Decorate algebra term -> yield (decoratorWithAlgebra algebra term) Diff differ terms -> yield (differ terms) Render renderer input -> yield (renderer input) From 97c8b90c836a06789d397a1d0d4e9b6de4dd60f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:47:07 -0400 Subject: [PATCH 19/49] runParser takes a Blob. --- src/Parser.hs | 21 +++++++++++---------- src/Semantic/Task.hs | 2 +- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 640fee3ae..4b597b21e 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -11,6 +11,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 @@ -72,19 +73,19 @@ pythonParser = AssignmentParser (ASTParser tree_sitter_python) headF Python.assi markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment -runParser :: Parser term -> Source -> IO term +runParser :: Parser term -> Blob -> 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 + ASTParser language -> parseToAST language . blobSource + AssignmentParser parser by assignment -> \ blob -> do + ast <- runParser parser blob + case assignBy by assignment (blobSource blob) ast of Left err -> do - printError source err - pure (errorTerm source) + printError (blobSource blob) err + pure (errorTerm (blobSource blob)) 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/Semantic/Task.hs b/src/Semantic/Task.hs index 45600433a..485f3967c 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -80,7 +80,7 @@ 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 blob -> runParser parser (blobSource blob) >>= 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) From b11cf64103a4bf54d122ba19ac23248885cb04e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 14:59:42 -0400 Subject: [PATCH 20/49] Pass the blob to printError. --- src/Data/Syntax/Assignment.hs | 7 ++++--- src/Parser.hs | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 9373a91e0..61e166b98 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 +printError :: Show grammar => Blob -> Error grammar -> IO () +printError Blob{..} error@Error{..} = do 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 ]) + 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/Parser.hs b/src/Parser.hs index 4b597b21e..70d555b3e 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -80,7 +80,7 @@ runParser parser = case parser of ast <- runParser parser blob case assignBy by assignment (blobSource blob) ast of Left err -> do - printError (blobSource blob) err + printError blob err pure (errorTerm (blobSource blob)) Right term -> pure term TreeSitterParser language tslanguage -> treeSitterParser language tslanguage . blobSource From 446ee85894852c1dc516be2b1c4441dfb421e38d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:02:27 -0400 Subject: [PATCH 21/49] =?UTF-8?q?Pass=20extant=20blobs=E2=80=99=20paths=20?= =?UTF-8?q?to=20showPos.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Syntax/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 61e166b98..4044052a5 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -190,7 +190,7 @@ data ErrorCause grammar -- | Pretty-print an Error with reference to the source where it occurred. printError :: Show grammar => Blob -> Error grammar -> IO () printError Blob{..} error@Error{..} = do - withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos Nothing errorPos . showString ": " + 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' From abd0e5ab41289929603c2c24ff1aabaed4b4d42d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:14:21 -0400 Subject: [PATCH 22/49] Correct the docs for readFile. --- src/Command/Files.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Command/Files.hs b/src/Command/Files.hs index 848efe380..58da6289c 100644 --- a/src/Command/Files.hs +++ b/src/Command/Files.hs @@ -21,7 +21,7 @@ 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)) From ab7b39e771200e063eb6aa7e6a79fd939644903c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:17:02 -0400 Subject: [PATCH 23/49] Align the doc comments for AssignmentParser. --- src/Parser.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 70d555b3e..12f076b7c 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -42,10 +42,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. From 90f4aa38a7e23fb785179d9464fcc5a93e5ac296 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:24:55 -0400 Subject: [PATCH 24/49] Define a high-level operation to read in blobs. --- src/Command/Files.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Command/Files.hs b/src/Command/Files.hs index 58da6289c..46625b409 100644 --- a/src/Command/Files.hs +++ b/src/Command/Files.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} module Command.Files -( readFile +( readBlobs +, readFile , readBlobPairsFromHandle , readBlobsFromHandle , languageForFilePath @@ -20,6 +21,10 @@ import qualified Data.ByteString.Lazy as BL import Prelude (fail) import System.FilePath +-- | Read a list of 'Blob.Blob's from either a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. +readBlobs :: Either Handle [(FilePath, Maybe Language)] -> IO [Blob.Blob] +readBlobs = either readBlobsFromHandle (traverse (uncurry readFile)) + -- | Read a utf8-encoded file to a 'Blob'. readFile :: FilePath -> Maybe Language -> IO Blob.Blob From 6afe6a94a4b185643390feab4eb9adff0b04d5d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:28:26 -0400 Subject: [PATCH 25/49] Define a high-level operation to read a pair of blobs --- src/Command/Files.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Command/Files.hs b/src/Command/Files.hs index 46625b409..d98e78538 100644 --- a/src/Command/Files.hs +++ b/src/Command/Files.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} module Command.Files ( readBlobs +, readBlobPairs , readFile , readBlobPairsFromHandle , readBlobsFromHandle @@ -25,6 +26,10 @@ import System.FilePath readBlobs :: Either Handle [(FilePath, Maybe Language)] -> IO [Blob.Blob] readBlobs = either readBlobsFromHandle (traverse (uncurry readFile)) +-- | Read a pair of 'Blob.Blob's from either a 'Handle' or a pair of 'FilePath's optionally paired with 'Language's. +readBlobPairs :: Either Handle (Both (FilePath, Maybe Language)) -> IO [Both Blob.Blob] +readBlobPairs = either readBlobPairsFromHandle (fmap pure . traverse (uncurry readFile)) + -- | Read a utf8-encoded file to a 'Blob'. readFile :: FilePath -> Maybe Language -> IO Blob.Blob From 97a4f75ca886cc9c6deb0c75364deac9c56ebaec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:37:01 -0400 Subject: [PATCH 26/49] Generalize readBlobPairs to lists of path/language pairs. --- src/Command/Files.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Command/Files.hs b/src/Command/Files.hs index d98e78538..d4d1be3e0 100644 --- a/src/Command/Files.hs +++ b/src/Command/Files.hs @@ -27,8 +27,8 @@ readBlobs :: Either Handle [(FilePath, Maybe Language)] -> IO [Blob.Blob] readBlobs = either readBlobsFromHandle (traverse (uncurry readFile)) -- | Read a pair of 'Blob.Blob's from either a 'Handle' or a pair of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: Either Handle (Both (FilePath, Maybe Language)) -> IO [Both Blob.Blob] -readBlobPairs = either readBlobPairsFromHandle (fmap pure . traverse (uncurry readFile)) +readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> IO [Both Blob.Blob] +readBlobPairs = either readBlobPairsFromHandle (traverse (traverse (uncurry readFile))) -- | Read a utf8-encoded file to a 'Blob'. From 8d43d19296c332cfb6f30365440e30f129960d5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:40:56 -0400 Subject: [PATCH 27/49] Construct Eithers for the input source(s). --- src/SemanticCmdLine.hs | 32 +++++++++++--------------------- test/SemanticCmdLineSpec.hs | 16 ++++++++-------- 2 files changed, 19 insertions(+), 29 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index e4e41c77a..f63e4bfce 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -2,13 +2,11 @@ module SemanticCmdLine ( main -- Testing -, DiffMode(..) , runDiff -, ParseMode(..) , runParse ) where -import Command.Files (languageForFilePath, readBlobsFromHandle, readBlobPairsFromHandle, readFile) +import Command.Files (languageForFilePath, readBlobs, readBlobPairs) import Data.Functor.Both import Data.List.Split (splitWhen) import Data.Version (showVersion) @@ -38,24 +36,17 @@ main = do writeToOutput :: Maybe FilePath -> ByteString -> IO () writeToOutput = maybe B.putStr B.writeFile -data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) - deriving Show - -runDiff :: SomeRenderer DiffRenderer -> DiffMode -> IO ByteString -runDiff (SomeRenderer diffRenderer) diffMode = do - blobs <- case diffMode of - DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b) - DiffStdin -> readBlobPairsFromHandle stdin +runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> IO ByteString +runDiff (SomeRenderer diffRenderer) from = do + blobs <- readBlobPairs from Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] deriving Show -runParse :: SomeRenderer TermRenderer -> ParseMode -> IO ByteString -runParse (SomeRenderer parseTreeRenderer) parseMode = do - blobs <- case parseMode of - ParsePaths paths -> traverse (uncurry readFile) paths - ParseStdin -> readBlobsFromHandle stdin +runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> IO ByteString +runParse (SomeRenderer parseTreeRenderer) from = do + blobs <- readBlobs from Task.runTask (Semantic.parseBlobs parseTreeRenderer blobs) -- | A parser for the application's command-line arguments. @@ -78,19 +69,18 @@ arguments = info (version <*> helper <*> argumentsParser) description <|> 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") ) - <*> ( DiffPaths + <*> ( ((Right . pure) .) . both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B") - <|> pure DiffStdin ) + <|> pure (Left stdin) ) parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)")) 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")) - <*> ( ParsePaths - <$> some (argument filePathReader (metavar "FILES...")) - <|> pure ParseStdin ) + <*> ( Right <$> some (argument filePathReader (metavar "FILES...")) + <|> pure (Left stdin) ) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 983068241..9f8488c95 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -26,17 +26,17 @@ spec = parallel $ do when (actual /= expected) $ print actual actual `shouldBe` expected -parseFixtures :: [(SomeRenderer TermRenderer, ParseMode, ByteString)] +parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)] parseFixtures = [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') - , (SomeRenderer JSONTermRenderer, ParsePaths [], emptyJsonParseTreeOutput) - , (SomeRenderer JSONTermRenderer, ParsePaths [("not-a-file.rb", Just Ruby)], emptyJsonParseTreeOutput) - , (SomeRenderer ToCTermRenderer, ParsePaths [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tocOutput) + , (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" @@ -45,14 +45,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" -diffFixtures :: [(SomeRenderer DiffRenderer, DiffMode, ByteString)] +diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)] diffFixtures = [ (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 [("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" From cbb6c885a4bdb7b04aad83124451fb8ed6c41641 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:41:40 -0400 Subject: [PATCH 28/49] Define Tasks to read blobs. --- src/Semantic/Task.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 485f3967c..aedb9ece7 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -3,6 +3,8 @@ module Semantic.Task ( Task , RAlgebra , Differ +, readBlobs +, readBlobPairs , parse , decorate , diff @@ -13,6 +15,7 @@ module Semantic.Task , runTask ) where +import qualified Command.Files as Files import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer @@ -21,11 +24,14 @@ import Data.Functor.Both as Both import Data.Record import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import Diff +import Language import Parser import Prologue import Term data TaskF output where + ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] + ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] 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) @@ -41,6 +47,14 @@ 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 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 parses 'Source' with the given 'Parser'. parse :: Parser term -> Blob -> Task term @@ -80,6 +94,8 @@ 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 + ReadBlobs source -> Files.readBlobs source >>= yield + ReadBlobPairs source -> Files.readBlobPairs source >>= yield Parse parser blob -> runParser parser blob >>= yield Decorate algebra term -> yield (decoratorWithAlgebra algebra term) Diff differ terms -> yield (differ terms) From 2cce3dd6711ba7e31a4264c2349f165ac160653b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:44:22 -0400 Subject: [PATCH 29/49] Define a Task to write output. --- src/Semantic/Task.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index aedb9ece7..8ff65959e 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -5,6 +5,7 @@ module Semantic.Task , Differ , readBlobs , readBlobPairs +, writeToOutput , parse , decorate , diff @@ -20,6 +21,7 @@ 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.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) @@ -32,6 +34,7 @@ import Term data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] + WriteToOutput :: Maybe 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) @@ -55,6 +58,9 @@ readBlobs from = ReadBlobs from `Then` return readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob] readBlobPairs from = ReadBlobPairs from `Then` return +writeToOutput :: Maybe FilePath -> ByteString -> Task () +writeToOutput path contents = WriteToOutput path contents `Then` return + -- | A 'Task' which parses 'Source' with the given 'Parser'. parse :: Parser term -> Blob -> Task term @@ -96,6 +102,7 @@ runTask :: Task a -> IO a runTask = iterFreerA $ \ task yield -> case task of ReadBlobs source -> Files.readBlobs source >>= yield ReadBlobPairs source -> Files.readBlobPairs source >>= yield + WriteToOutput path contents -> maybe B.putStr B.writeFile path contents >>= yield Parse parser blob -> runParser parser blob >>= yield Decorate algebra term -> yield (decoratorWithAlgebra algebra term) Diff differ terms -> yield (differ terms) From 17af42e21ebe858d20e87ee1aa2cb28f347ca46d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:46:27 -0400 Subject: [PATCH 30/49] Define runDiff by composition. --- src/SemanticCmdLine.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index f63e4bfce..1d5f48700 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -37,9 +37,7 @@ main = do writeToOutput = maybe B.putStr B.writeFile runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> IO ByteString -runDiff (SomeRenderer diffRenderer) from = do - blobs <- readBlobPairs from - Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) +runDiff (SomeRenderer diffRenderer) = Task.runTask . Semantic.diffBlobPairs diffRenderer <=< readBlobPairs data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] deriving Show From fe21d792fea835b78b0af794b54431e1ce8105e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:46:31 -0400 Subject: [PATCH 31/49] Define runParse by composition. --- src/SemanticCmdLine.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 1d5f48700..f20ab3377 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -43,9 +43,7 @@ data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] deriving Show runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> IO ByteString -runParse (SomeRenderer parseTreeRenderer) from = do - blobs <- readBlobs from - Task.runTask (Semantic.parseBlobs parseTreeRenderer blobs) +runParse (SomeRenderer parseTreeRenderer) = Task.runTask . Semantic.parseBlobs parseTreeRenderer <=< readBlobs -- | A parser for the application's command-line arguments. -- From 4d5ffe7a11a29cd4c053390d43b7ec92d4852da2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 15:46:49 -0400 Subject: [PATCH 32/49] :fire: ParseMode. --- src/SemanticCmdLine.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index f20ab3377..ace0c7182 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -39,9 +39,6 @@ main = do runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> IO ByteString runDiff (SomeRenderer diffRenderer) = Task.runTask . Semantic.diffBlobPairs diffRenderer <=< readBlobPairs -data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] - deriving Show - runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> IO ByteString runParse (SomeRenderer parseTreeRenderer) = Task.runTask . Semantic.parseBlobs parseTreeRenderer <=< readBlobs From c0f894162e4e023b4a5560c47cb5298c08014163 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:15:44 -0400 Subject: [PATCH 33/49] Derive an NFData instance for Language. --- src/Language.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language.hs b/src/Language.hs index f86897322..5a0f22c23 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -18,7 +18,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 From c8416ee0fd7a63d2f179d3d17c21e65c8fa29386 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:16:51 -0400 Subject: [PATCH 34/49] Pass blobs to the declaration algebras. --- src/Renderer/TOC.hs | 22 +++++++++++----------- src/Semantic.hs | 14 +++++++------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 9c249cf04..217ea7bff 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -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)) _ -> 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)) | 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 +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)) | otherwise = Nothing - where getSource = firstLine . toText . flip Source.slice source . byteRange + where getSource = firstLine . toText . flip Source.slice blobSource . byteRange firstLine = T.takeWhile (/= '\n') diff --git a/src/Semantic.hs b/src/Semantic.hs index babcedc25..cf08178fe 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -42,9 +42,9 @@ 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 blob >>= decorate (markupSectionAlgebra blobSource) >>= render (renderToCTerm blob) - (ToCTermRenderer, Just Language.Python) -> parse pythonParser blob >>= decorate (declarationAlgebra blobSource) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) - (ToCTermRenderer, _) -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blobSource) >>= render (renderToCTerm blob) + (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, _) -> parse syntaxParser blob >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) @@ -64,9 +64,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 (\ blob -> parse markdownParser blob >>= decorate (markupSectionAlgebra (blobSource blob))) diffLinearly (renderToCDiff blobs) - (ToCDiffRenderer, Just Language.Python) -> run (\ blob -> parse pythonParser blob >>= decorate (declarationAlgebra (blobSource blob)) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs) - (ToCDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra (blobSource blob))) 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, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs) @@ -76,7 +76,7 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of (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, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . mapAnnotations keepCategory) - (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra (blobSource blob))) diffTerms Just + (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs) syntaxParser = parserForLanguage effectiveLanguage From a85aa1f8ffa3b7d77b1445e2d570a1c94b6a392c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:17:39 -0400 Subject: [PATCH 35/49] Carry the language in error declarations. --- src/Renderer/TOC.hs | 47 ++++++++++++++++++++------------------------- 1 file changed, 21 insertions(+), 26 deletions(-) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 217ea7bff..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 @@ -101,7 +101,7 @@ syntaxDeclarationAlgebra Blob{..} r = case tailF r of | 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)) blobSource)) + S.ParseError{} -> Just $ ErrorDeclaration (toText (Source.slice (byteRange (headF r)) blobSource)) blobLanguage _ -> Nothing where getSource = toText . flip Source.slice blobSource . byteRange . extract @@ -112,7 +112,7 @@ declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syn 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 blobSource . byteRange @@ -122,7 +122,7 @@ markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fiel -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) 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)) + | Just Syntax.Error{} <- prj (tailF r) = Just $ ErrorDeclaration (getSource (headF r)) blobLanguage | otherwise = Nothing 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) From 1cb3541efe435461d0bf655b1758c851d056d1ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:22:10 -0400 Subject: [PATCH 36/49] Construct a task in the options parser. --- src/SemanticCmdLine.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index ace0c7182..58bec0cd4 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -6,7 +6,7 @@ module SemanticCmdLine , runParse ) where -import Command.Files (languageForFilePath, readBlobs, readBlobPairs) +import Command.Files (languageForFilePath) import Data.Functor.Both import Data.List.Split (splitWhen) import Data.Version (showVersion) @@ -25,9 +25,9 @@ import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () main = do - (command, outputFilePath) <- customExecParser (prefs showHelpOnEmpty) arguments + (task, outputFilePath) <- customExecParser (prefs showHelpOnEmpty) arguments outputPath <- traverse getOutputPath outputFilePath - text <- command + text <- Task.runTask task writeToOutput outputPath text where getOutputPath path = do @@ -36,16 +36,16 @@ main = do writeToOutput :: Maybe FilePath -> ByteString -> IO () writeToOutput = maybe B.putStr B.writeFile -runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> IO ByteString -runDiff (SomeRenderer diffRenderer) = Task.runTask . Semantic.diffBlobPairs diffRenderer <=< readBlobPairs +runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString +runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs -runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> IO ByteString -runParse (SomeRenderer parseTreeRenderer) = Task.runTask . Semantic.parseBlobs parseTreeRenderer <=< readBlobs +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. -- -- Returns an 'IO' action producing 'ByteString' output, and a 'Maybe FilePath' to write the output to. -arguments :: ParserInfo (IO ByteString, Maybe FilePath) +arguments :: ParserInfo (Task.Task ByteString, Maybe FilePath) arguments = info (version <*> helper <*> argumentsParser) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") From 844b8d0dc337fd0b4ef2ebc2387f23df5e532b47 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:23:44 -0400 Subject: [PATCH 37/49] Run tasks in the spec. --- test/SemanticCmdLineSpec.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 9f8488c95..ecf2c9577 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -4,6 +4,7 @@ module SemanticCmdLineSpec where import Prologue import Language import Renderer +import Semantic.Task import SemanticCmdLine import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty @@ -13,13 +14,13 @@ spec = parallel $ do describe "runDiff" $ for_ diffFixtures $ \ (diffRenderer, diffMode, expected) -> it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do - output <- runDiff diffRenderer diffMode + output <- runTask $ runDiff diffRenderer diffMode output `shouldBe'` expected describe "runParse" $ for_ parseFixtures $ \ (parseTreeRenderer, parseMode, expected) -> it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do - output <- runParse parseTreeRenderer parseMode + output <- runTask $ runParse parseTreeRenderer parseMode output `shouldBe'` expected where shouldBe' actual expected = do From aad5e2d396c4104e74ad55468346c0e06cb482ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:24:06 -0400 Subject: [PATCH 38/49] Correct the docs. --- src/SemanticCmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 58bec0cd4..02db14372 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -44,7 +44,7 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere -- | A parser for the application's command-line arguments. -- --- Returns an 'IO' action producing 'ByteString' output, and a 'Maybe FilePath' to write the output to. +-- Returns a 'Task' producing 'ByteString' output, and a 'Maybe FilePath' to write the output to. arguments :: ParserInfo (Task.Task ByteString, Maybe FilePath) arguments = info (version <*> helper <*> argumentsParser) description where From 766f71ba90441465598e30b3db4747b4aa136898 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:26:52 -0400 Subject: [PATCH 39/49] :fire: the obsolete getOutputPath logic. --- src/SemanticCmdLine.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 02db14372..ead476ac2 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -19,20 +19,15 @@ 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 - (task, outputFilePath) <- customExecParser (prefs showHelpOnEmpty) arguments - outputPath <- traverse getOutputPath outputFilePath + (task, outputPath) <- customExecParser (prefs showHelpOnEmpty) arguments text <- Task.runTask task 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 From beb6c4788c50b304424f64dff49306361f3217e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:29:38 -0400 Subject: [PATCH 40/49] WriteToOutput takes a handle or a path. --- src/Semantic/Task.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 8ff65959e..7a6056ee0 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -34,7 +34,7 @@ import Term data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] - WriteToOutput :: Maybe FilePath -> ByteString -> TaskF () + 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) @@ -58,7 +58,7 @@ readBlobs from = ReadBlobs from `Then` return readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob] readBlobPairs from = ReadBlobPairs from `Then` return -writeToOutput :: Maybe FilePath -> ByteString -> Task () +writeToOutput :: Either Handle FilePath -> ByteString -> Task () writeToOutput path contents = WriteToOutput path contents `Then` return @@ -102,7 +102,7 @@ runTask :: Task a -> IO a runTask = iterFreerA $ \ task yield -> case task of ReadBlobs source -> Files.readBlobs source >>= yield ReadBlobPairs source -> Files.readBlobPairs source >>= yield - WriteToOutput path contents -> maybe B.putStr B.writeFile path contents >>= 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) From 71356ead42fce7310ef0609929cfc7f836fdf30c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:39:48 -0400 Subject: [PATCH 41/49] Construct a single task. --- src/SemanticCmdLine.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index ead476ac2..09f27d155 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -15,21 +15,15 @@ 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.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () main = do - (task, outputPath) <- customExecParser (prefs showHelpOnEmpty) arguments - text <- Task.runTask task - writeToOutput outputPath text - where - writeToOutput :: Maybe FilePath -> ByteString -> IO () - writeToOutput = maybe B.putStr B.writeFile + task <- customExecParser (prefs showHelpOnEmpty) arguments + Task.runTask task runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs @@ -39,17 +33,17 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere -- | A parser for the application's command-line arguments. -- --- Returns a 'Task' producing 'ByteString' output, and a 'Maybe FilePath' to write the output to. -arguments :: ParserInfo (Task.Task ByteString, Maybe FilePath) +-- 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 = (,) + argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) - <*> optional (strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")) + <*> (maybe (Left stdout) Right <$> optional (strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout"))) diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths")) diffArgumentsParser = runDiff From 8d73a83cdf608eec98046799ae7c0c3e6d9f88cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 17:41:06 -0400 Subject: [PATCH 42/49] Bind instead of using do notation. --- src/SemanticCmdLine.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 09f27d155..d7204d278 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -21,9 +21,7 @@ import System.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () -main = do - task <- customExecParser (prefs showHelpOnEmpty) arguments - Task.runTask task +main = customExecParser (prefs showHelpOnEmpty) arguments >>= Task.runTask runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs From 839c64b4a37256724eb0ef9ce845cf60e29770d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 19:57:36 -0400 Subject: [PATCH 43/49] Rename Command.Files to Files. --- semantic-diff.cabal | 2 +- src/{Command => }/Files.hs | 2 +- src/Semantic/Task.hs | 2 +- src/SemanticCmdLine.hs | 2 +- test/CommandSpec.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) rename src/{Command => }/Files.hs (99%) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 1ddd90e27..a683994a4 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -16,7 +16,6 @@ library exposed-modules: Algorithm , Alignment , Category - , Command.Files , Data.Align.Generic , Data.Blob , Data.Functor.Both @@ -42,6 +41,7 @@ library , Data.Text.Listable , Decorators , Diff + , Files , Info , Interpreter , Language diff --git a/src/Command/Files.hs b/src/Files.hs similarity index 99% rename from src/Command/Files.hs rename to src/Files.hs index d4d1be3e0..5a3932daf 100644 --- a/src/Command/Files.hs +++ b/src/Files.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} -module Command.Files +module Files ( readBlobs , readBlobPairs , readFile diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 7a6056ee0..8c0ad8901 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -16,7 +16,7 @@ module Semantic.Task , runTask ) where -import qualified Command.Files as Files +import qualified Files import Control.Parallel.Strategies import qualified Control.Concurrent.Async as Async import Control.Monad.Free.Freer diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index d7204d278..19831a40c 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -6,7 +6,7 @@ module SemanticCmdLine , runParse ) where -import Command.Files (languageForFilePath) +import Files (languageForFilePath) import Data.Functor.Both import Data.List.Split (splitWhen) import Data.Version (showVersion) diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs index 061edc349..3a81d9ba1 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -1,6 +1,6 @@ module CommandSpec where -import Command.Files +import Files import Data.Blob import Data.Functor.Both as Both import Data.Maybe From 201f9358f838c51fb28a54c93c4f49af373662cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 20:01:59 -0400 Subject: [PATCH 44/49] Correct the tests. --- test/SemanticCmdLineSpec.hs | 5 +++-- test/TOCSpec.hs | 20 ++++++++++---------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index ecf2c9577..c2b7f346f 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DuplicateRecordFields #-} module SemanticCmdLineSpec where -import Prologue +import Data.Functor.Both import Language +import Prologue import Renderer import Semantic.Task import SemanticCmdLine @@ -53,7 +54,7 @@ diffFixtures = , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput) , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput) ] - where pathMode = Right [("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' From aaf39930b0384b6fa534e692840d6f24386251e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 20:07:17 -0400 Subject: [PATCH 45/49] Simplify how the output is defaulted to stdout. --- src/SemanticCmdLine.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 19831a40c..01cfa3edb 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -41,7 +41,8 @@ arguments = info (version <*> helper <*> argumentsParser) description argumentsParser = (. Task.writeToOutput) . (>>=) <$> hsubparser (diffCommand <> parseCommand) - <*> (maybe (Left stdout) Right <$> 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 = runDiff From e6739b543033f27ae6bf94e10ade8a8713797b5d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 20:18:44 -0400 Subject: [PATCH 46/49] :memo: writeToOutput. --- src/Semantic/Task.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 8c0ad8901..9f39f5c3f 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -58,6 +58,7 @@ readBlobs from = ReadBlobs from `Then` return 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 From 6f1cf00255c382d7c7d5da1f5ecff29b450d49ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 20:20:20 -0400 Subject: [PATCH 47/49] Move the implementations of readBlobs/readBlobPairs into Task. --- src/Files.hs | 13 +------------ src/Semantic/Task.hs | 4 ++-- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/src/Files.hs b/src/Files.hs index 5a3932daf..874e5ee08 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-} module Files -( readBlobs -, readBlobPairs -, readFile +( readFile , readBlobPairsFromHandle , readBlobsFromHandle , languageForFilePath @@ -22,15 +20,6 @@ import qualified Data.ByteString.Lazy as BL import Prelude (fail) import System.FilePath --- | Read a list of 'Blob.Blob's from either a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -readBlobs :: Either Handle [(FilePath, Maybe Language)] -> IO [Blob.Blob] -readBlobs = either readBlobsFromHandle (traverse (uncurry readFile)) - --- | Read a pair of 'Blob.Blob's from either a 'Handle' or a pair of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> IO [Both Blob.Blob] -readBlobPairs = either readBlobPairsFromHandle (traverse (traverse (uncurry readFile))) - - -- | Read a utf8-encoded file to a 'Blob'. readFile :: FilePath -> Maybe Language -> IO Blob.Blob readFile path language = do diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 9f39f5c3f..a610fc098 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -101,8 +101,8 @@ 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 - ReadBlobs source -> Files.readBlobs source >>= yield - ReadBlobPairs source -> Files.readBlobPairs 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) From f9ce0a9e63858c875d1c8ee8e1a7d24e592d45c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 19 Jul 2017 20:24:52 -0400 Subject: [PATCH 48/49] Take the blob parameter explicitly. --- src/Parser.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Parser.hs b/src/Parser.hs index 12f076b7c..5a4b7baee 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -74,18 +74,18 @@ markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment runParser :: Parser term -> Blob -> IO term -runParser parser = case parser of - ASTParser language -> parseToAST language . blobSource - AssignmentParser parser by assignment -> \ blob -> do +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 blob) ast of + case assignBy by assignment blobSource ast of Left err -> do printError blob err - pure (errorTerm (blobSource blob)) + pure (errorTerm blobSource) Right term -> pure term - TreeSitterParser language tslanguage -> treeSitterParser language tslanguage . blobSource - MarkdownParser -> pure . cmarkParser . blobSource - LineByLineParser -> pure . lineByLineParser . blobSource + 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 [])) From 734e42802dfc2a6cac25b15a1126dba2cf5479c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 20 Jul 2017 10:23:35 -0400 Subject: [PATCH 49/49] Correct the docs for `parse`. --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a610fc098..d32f37142 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -63,7 +63,7 @@ writeToOutput :: Either Handle FilePath -> ByteString -> Task () writeToOutput path contents = WriteToOutput path contents `Then` return --- | A 'Task' which parses 'Source' with the given 'Parser'. +-- | A 'Task' which parses a 'Blob' with the given 'Parser'. parse :: Parser term -> Blob -> Task term parse parser blob = Parse parser blob `Then` return