Merge branch 'master' into parser-abstraction

semantic-diff.cabal

@@ -128,6 +128,7 @@ library
                      , network
                      , clock
                      , yaml
+                     , unordered-containers
   default-language:    Haskell2010
   default-extensions:  DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, StrictData
   ghc-options:        -Wall -fno-warn-name-shadowing -O2 -j

src/Arguments.hs

@@ -14,7 +14,7 @@ import Syntax
 import Term
 import Text.Show
 
-data DiffMode = DiffCommits String String [(FilePath, Maybe Language)] | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language)
+data DiffMode = DiffStdin | DiffCommits String String [(FilePath, Maybe Language)] | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language)
   deriving Show
 
 data DiffArguments where
@@ -53,7 +53,7 @@ tocDiff :: DiffArguments'
 tocDiff = DiffArguments ToCRenderer declarationDecorator
 
 
-data ParseMode = ParseCommit String [(FilePath, Maybe Language)] | ParsePaths [(FilePath, Maybe Language)]
+data ParseMode = ParseStdin | ParseCommit String [(FilePath, Maybe Language)] | ParsePaths [(FilePath, Maybe Language)]
   deriving Show
 
 data ParseArguments where

src/Command.hs

@@ -3,6 +3,8 @@ module Command
 ( Command
 -- Constructors
 , readFile
+, readBlobPairsFromHandle
+, readBlobsFromHandle
 , readFilesAtSHA
 , readFilesAtSHAs
 -- Evaluation
@@ -32,6 +34,14 @@ type Command = Freer CommandF
 readFile :: FilePath -> Maybe Language -> Command SourceBlob
 readFile path lang = ReadFile path lang `Then` return
 
+-- | Read JSON encoded blob pairs to SourceBlobs.
+readBlobPairsFromHandle :: Handle -> Command [Both SourceBlob]
+readBlobPairsFromHandle h = ReadBlobPairsFromHandle h `Then` return
+
+-- | Read JSON encoded blobs to SourceBlobs.
+readBlobsFromHandle :: Handle -> Command [SourceBlob]
+readBlobsFromHandle h = ReadBlobsFromHandle h `Then` return
+
 -- | Read a list of files at the given commit SHA.
 readFilesAtSHA :: FilePath -- ^ GIT_DIR
                 -> [FilePath] -- ^ GIT_ALTERNATE_OBJECT_DIRECTORIES
@@ -55,6 +65,8 @@ readFilesAtSHAs gitDir alternates paths shas = ReadFilesAtSHAs gitDir alternates
 runCommand :: Command a -> IO a
 runCommand = iterFreerA $ \ command yield -> case command of
   ReadFile path lang -> Files.readFile path lang >>= yield
+  ReadBlobPairsFromHandle h -> Files.readBlobPairsFromHandle h >>= yield
+  ReadBlobsFromHandle h -> Files.readBlobsFromHandle h >>= yield
   ReadFilesAtSHA gitDir alternates paths sha -> Git.readFilesAtSHA gitDir alternates paths sha >>= yield
   ReadFilesAtSHAs gitDir alternates paths shas -> Git.readFilesAtSHAs gitDir alternates paths shas >>= yield
   LiftIO io -> io >>= yield
@@ -64,6 +76,8 @@ runCommand = iterFreerA $ \ command yield -> case command of
 
 data CommandF f where
   ReadFile :: FilePath -> Maybe Language -> CommandF SourceBlob
+  ReadBlobPairsFromHandle :: Handle -> CommandF [Both SourceBlob]
+  ReadBlobsFromHandle :: Handle -> CommandF [SourceBlob]
   ReadFilesAtSHA :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> String -> CommandF [SourceBlob]
   ReadFilesAtSHAs :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> Both String -> CommandF [Both SourceBlob]
   LiftIO :: IO a -> CommandF a
@@ -74,6 +88,8 @@ instance MonadIO Command where
 instance Show1 CommandF where
   liftShowsPrec _ _ d command = case command of
     ReadFile path lang -> showsBinaryWith showsPrec showsPrec "ReadFile" d path lang
+    ReadBlobPairsFromHandle h -> showsUnaryWith showsPrec "ReadBlobPairsFromHandle" d h
+    ReadBlobsFromHandle h -> showsUnaryWith showsPrec "ReadBlobsFromHandle" d h
     ReadFilesAtSHA gitDir alternates paths sha -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHA" d gitDir alternates paths sha
     ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas
     LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_'

src/Command/Files.hs

@@ -1,17 +1,27 @@
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-}
 module Command.Files
 ( readFile
+, readBlobPairsFromHandle
+, readBlobsFromHandle
 , transcode
 , languageForFilePath
 ) where
 
-import Prologue hiding (readFile)
-import Language
-import Source
-import qualified Data.ByteString as B
-import System.FilePath
 import Control.Exception (catch, IOException)
+import Data.Aeson
+import Data.These
+import Data.Functor.Both
+import Data.String
+import Language
+import Prologue hiding (readFile)
+import qualified Data.ByteString as B
+import qualified Data.HashMap.Strict as HM
 import qualified Data.Text.ICU.Convert as Convert
 import qualified Data.Text.ICU.Detect as Detect
+import Prelude (fail)
+import Source hiding (path)
+import System.FilePath
+
 
 -- | Read a file to a SourceBlob, transcoding to UTF-8 along the way.
 readFile :: FilePath -> Maybe Language -> IO SourceBlob
@@ -30,3 +40,52 @@ transcode text = fromText <$> do
 -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
 languageForFilePath :: FilePath -> Maybe Language
 languageForFilePath = languageForType . toS . takeExtension
+
+-- | Read JSON encoded blob pairs from a handle.
+readBlobPairsFromHandle :: Handle -> IO [Both SourceBlob]
+readBlobPairsFromHandle = fmap toSourceBlobPairs . readFromHandle
+  where
+    toSourceBlobPairs BlobDiff{..} = toSourceBlobPair <$> blobs
+    toSourceBlobPair blobs = Join (fromThese empty empty (runJoin (toSourceBlob <$> blobs)))
+      where empty = emptySourceBlob (mergeThese const (runJoin (path <$> blobs)))
+
+-- | Read JSON encoded blobs from a handle.
+readBlobsFromHandle :: Handle -> IO [SourceBlob]
+readBlobsFromHandle = fmap toSourceBlobs . readFromHandle
+  where toSourceBlobs BlobParse{..} = fmap toSourceBlob blobs
+
+readFromHandle :: FromJSON a => Handle -> IO a
+readFromHandle h = do
+  input <- B.hGetContents h
+  case decode (toS input) of
+    Just d -> pure d
+    Nothing -> die ("invalid input on " <> show h <> ", expecting JSON")
+
+toSourceBlob :: Blob -> SourceBlob
+toSourceBlob Blob{..} = sourceBlob path language' (Source (encodeUtf8 content))
+  where language' = case language of
+          "" -> languageForFilePath path
+          _ -> readMaybe language
+
+
+newtype BlobDiff = BlobDiff { blobs :: [BlobPair] }
+  deriving (Show, Generic, FromJSON)
+
+newtype BlobParse = BlobParse { blobs :: [Blob] }
+  deriving (Show, Generic, FromJSON)
+
+type BlobPair = Join These Blob
+
+data Blob = Blob
+  { path :: String
+  , content :: Text
+  , language :: String
+  } deriving (Show, Generic, FromJSON)
+
+instance FromJSON BlobPair where
+  parseJSON = withObject "BlobPair" $ \o ->
+    case (HM.lookup "before" o, HM.lookup "after" o) of
+      (Just before, Just after) -> Join <$> (These <$> parseJSON before <*> parseJSON after)
+      (Just before, Nothing) -> Join . This <$> parseJSON before
+      (Nothing, Just after) -> Join . That <$> parseJSON after
+      _ -> fail "Expected object with 'before' and/or 'after' keys only"

src/SemanticCmdLine.hs

@@ -17,6 +17,7 @@ import System.Directory
 import System.Environment
 import System.FilePath.Posix (takeFileName, (-<.>))
 import System.IO.Error (IOError)
+import System.IO (stdin)
 import Text.Regex
 import qualified Semantic (parseBlobs, diffBlobPairs)
 
@@ -48,8 +49,9 @@ main = do
 runDiff :: DiffArguments -> IO ByteString
 runDiff DiffArguments{..} = do
   blobs <- runCommand $ case diffMode of
-   DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b)
-   DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+    DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b)
+    DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+    DiffStdin -> readBlobPairsFromHandle stdin
   Semantic.diffBlobPairs termDecorator diffRenderer blobs
 
 runParse :: ParseArguments -> IO ByteString
@@ -57,6 +59,7 @@ runParse ParseArguments{..} = do
   blobs <- runCommand $ case parseMode of
     ParsePaths paths -> traverse (uncurry readFile) paths
     ParseCommit sha paths -> readFilesAtSHA gitDir alternateObjectDirs paths sha
+    ParseStdin -> readBlobsFromHandle stdin
   Semantic.parseBlobs parseTreeRenderer blobs
 
 -- | A parser for the application's command-line arguments.
@@ -84,7 +87,8 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
             <|> DiffCommits
                <$> option (eitherReader parseSha) (long "sha1" <> metavar "SHA" <> help "Starting commit SHA")
                <*> option (eitherReader parseSha) (long "sha2" <> metavar "SHA" <> help "Ending commit SHA")
-               <*> many (argument filePathReader (metavar "FILES...")) )
+               <*> many (argument filePathReader (metavar "FILES..."))
+            <|> pure DiffStdin )
          <*> pure gitDir
          <*> pure alternates )
 
@@ -96,7 +100,8 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
                <$> some (argument filePathReader (metavar "FILES..."))
             <|> ParseCommit
                <$> option (eitherReader parseSha) (long "sha" <> metavar "SHA" <> help "Commit SHA")
-               <*> some (argument filePathReader (metavar "FILES...")) )
+               <*> some (argument filePathReader (metavar "FILES..."))
+            <|> pure ParseStdin )
          <*> pure gitDir
          <*> pure alternates )
 

test/CommandSpec.hs

@@ -31,6 +31,47 @@ spec = parallel $ do
       blob <- runCommand (readFile "this file should not exist" Nothing)
       nullBlob blob `shouldBe` True
 
+  describe "readBlobPairsFromHandle" $ do
+    it "returns blobs for valid JSON encoded diff input" $ do
+      h <- openFile "test/fixtures/input/diff.json" ReadMode
+      blobs <- runCommand (readBlobPairsFromHandle h)
+      let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
+      let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end"
+      blobs `shouldBe` [both a b]
+
+    it "returns blobs for unsupported language" $ do
+      h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode
+      blobs <- runCommand (readBlobPairsFromHandle h)
+      let a = emptySourceBlob "test.kt"
+      let b = sourceBlob "test.kt" Nothing "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
+      blobs `shouldBe` [both a b]
+
+    it "detects language based on filepath for empty language" $ do
+      h <- openFile "test/fixtures/input/diff-empty-language.json" ReadMode
+      blobs <- runCommand (readBlobPairsFromHandle h)
+      let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
+      let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end"
+      blobs `shouldBe` [both a b]
+
+    it "throws on blank input" $ do
+      h <- openFile "test/fixtures/input/blank.json" ReadMode
+      runCommand (readBlobPairsFromHandle h) `shouldThrow` (== ExitFailure 1)
+
+    it "throws if language field not given" $ do
+      h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode
+      runCommand (readBlobsFromHandle h) `shouldThrow` (== ExitFailure 1)
+
+  describe "readBlobsFromHandle" $ do
+    it "returns blobs for valid JSON encoded parse input" $ do
+      h <- openFile "test/fixtures/input/parse.json" ReadMode
+      blobs <- runCommand (readBlobsFromHandle h)
+      let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
+      blobs `shouldBe` [a]
+
+    it "throws on blank input" $ do
+      h <- openFile "test/fixtures/input/blank.json" ReadMode
+      runCommand (readBlobsFromHandle h) `shouldThrow` (== ExitFailure 1)
+
   describe "readFilesAtSHA" $ do
     it "returns blobs for the specified paths" $ do
       blobs <- runCommand (readFilesAtSHA repoPath [] [("methods.rb", Just Ruby)] (Both.snd (shas methodsFixture)))

test/fixtures/input/diff-empty-language.json

@@ -0,0 +1,14 @@
+{
+  "blobs": [{
+    "before": {
+      "path": "method.rb",
+      "content": "def foo; end",
+      "language": ""
+    },
+    "after": {
+      "path": "method.rb",
+      "content": "def bar(x); end",
+      "language": ""
+    }
+  }]
+}

test/fixtures/input/diff-no-language.json

@@ -0,0 +1,12 @@
+{
+  "blobs": [{
+    "before": {
+      "path": "method.rb",
+      "content": "def foo; end",
+    },
+    "after": {
+      "path": "method.rb",
+      "content": "def bar(x); end",
+    }
+  }]
+}

test/fixtures/input/diff-unsupported-language.json

@@ -0,0 +1,9 @@
+{
+  "blobs": [{
+    "after": {
+      "path": "test.kt",
+      "content": "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n",
+      "language": "Kotlin"
+    }
+  }]
+}

test/fixtures/input/diff.json

@@ -0,0 +1,14 @@
+{
+  "blobs": [{
+    "before": {
+      "path": "method.rb",
+      "content": "def foo; end",
+      "language": "Ruby"
+    },
+    "after": {
+      "path": "method.rb",
+      "content": "def bar(x); end",
+      "language": "Ruby"
+    }
+  }]
+}

test/fixtures/input/parse.json

@@ -0,0 +1,7 @@
+{
+  "blobs": [{
+    "path": "method.rb",
+    "content": "def foo; end",
+    "language": "Ruby"
+  }]
+}