Expand API to support parsing

src/Arguments.hs

@@ -56,7 +56,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

@@ -4,6 +4,7 @@ module Command
 -- Constructors
 , readFile
 , readBlobPairsFromHandle
+, readBlobsFromHandle
 , readFilesAtSHA
 , readFilesAtSHAs
 -- Evaluation
@@ -37,6 +38,9 @@ readFile path lang = ReadFile path lang `Then` return
 readBlobPairsFromHandle :: Handle -> Command [Both SourceBlob]
 readBlobPairsFromHandle h = ReadBlobPairsFromHandle h `Then` return
 
+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
@@ -61,6 +65,7 @@ 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
@@ -71,6 +76,7 @@ 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
@@ -82,6 +88,7 @@ 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,24 +1,24 @@
-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass #-}
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-}
 module Command.Files
 ( readFile
 , readBlobPairsFromHandle
+, readBlobsFromHandle
 , transcode
 , languageForFilePath
 ) where
 
-import Prologue hiding (readFile)
-import Language
-import Source
-import System.FilePath
 import Control.Exception (catch, IOException)
-import qualified Data.Text.ICU.Convert as Convert
-import qualified Data.Text.ICU.Detect as Detect
-
-import qualified Control.Applicative as A
 import Data.Aeson
-import qualified Data.ByteString as B
 import Data.Functor.Both
 import Data.String
+import Language
+import Prologue hiding (readFile)
+import qualified Control.Applicative as A
+import qualified Data.ByteString as B
+import qualified Data.Text.ICU.Convert as Convert
+import qualified Data.Text.ICU.Detect as Detect
+import Source
+import System.FilePath
 
 
 -- | Read a file to a SourceBlob, transcoding to UTF-8 along the way.
@@ -39,18 +39,36 @@ transcode text = fromText <$> do
 languageForFilePath :: FilePath -> Maybe Language
 languageForFilePath = languageForType . toS . takeExtension
 
--- | Read JSON encoded blobs from a handle.
+-- | Read JSON encoded blob pairs from a handle.
 readBlobPairsFromHandle :: Handle -> IO [Both SourceBlob]
-readBlobPairsFromHandle h = do
+readBlobPairsFromHandle = readFromHandle toSourceBlobPairs
+  where
+    toSourceBlobPairs BlobDiff{..} = toSourceBlobPair <$> blobs
+    toSourceBlobPair BlobPair{..} = fmap (maybe (emptySourceBlob path) toSourceBlob) (both before after)
+
+-- | Read JSON encoded blobs from a handle.
+readBlobsFromHandle :: Handle -> IO [SourceBlob]
+readBlobsFromHandle = readFromHandle toSourceBlobs
+  where
+    toSourceBlobs BlobParse{..} = fmap toSourceBlob blobs
+
+readFromHandle :: (FromJSON a, Monoid b) => (a -> b) -> Handle -> IO b
+readFromHandle f h = do
   input <- B.hGetContents h
-  let request = decode (toS input) :: Maybe BlobDiff
-  when (isNothing request) $ die ("invalid input on " <> show h <> ", expecting JSON")
-  pure $ maybe mempty sourceBlobs request
+  let d = decode (toS input)
+  when (isNothing d) $ die ("invalid input on " <> show h <> ", expecting JSON")
+  pure $ maybe mempty f d
+
+toSourceBlob :: Blob -> SourceBlob
+toSourceBlob Blob{..} = sourceBlob path (readMaybe language) (Source (utf8Text content))
 
 
 newtype BlobDiff = BlobDiff { blobs :: [BlobPair] }
   deriving (Show, Generic, FromJSON, ToJSON)
 
+newtype BlobParse = BlobParse { blobs :: [Blob] }
+  deriving (Show, Generic, FromJSON, ToJSON)
+
 data BlobPair = BlobPair
   { path :: String
   , before :: Maybe Blob
@@ -58,7 +76,8 @@ data BlobPair = BlobPair
   } deriving (Show, Generic, FromJSON, ToJSON)
 
 data Blob = Blob
-  { content :: BlobContent
+  { path :: String
+  , content :: BlobContent
   , language :: String
   } deriving (Show, Generic, FromJSON, ToJSON)
 
@@ -71,19 +90,3 @@ instance ToJSON BlobContent where
 instance FromJSON BlobContent where
   parseJSON (String t) = (pure . BlobContent . encodeUtf8) t
   parseJSON _ = A.empty
-
-sourceBlobs :: BlobDiff -> [Both SourceBlob]
-sourceBlobs BlobDiff{..} = toSourceBlob <$> blobs
-  where
-    toSourceBlob :: BlobPair -> Both SourceBlob
-    toSourceBlob BlobPair{..} = fmap (sourceBlob' path) (both before after)
-
-    sourceBlob' :: FilePath -> Maybe Blob -> SourceBlob
-    sourceBlob' path c = maybe (emptySourceBlob path) (sourceBlob path (language' c)) (source' c)
-
-    language' :: Maybe Blob -> Maybe Language
-    language' Nothing = Nothing
-    language' (Just Blob{..}) = readMaybe language
-
-    source' :: Maybe Blob -> Maybe Source
-    source' = fmap (Source . utf8Text . content)

src/SemanticCmdLine.hs

@@ -59,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.
@@ -100,7 +101,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

@@ -33,7 +33,7 @@ spec = parallel $ do
 
   describe "readBlobPairsFromHandle" $ do
     it "returns blobs for valid JSON encoded diff input" $ do
-      h <- openFile "test/fixtures/input/test.json" ReadMode
+      h <- openFile "test/fixtures/input/diff.json" ReadMode
       blobs <- runCommand (readBlobPairsFromHandle h)
       let a = sourceBlob "method.rb" (Just Ruby) (Source "def foo; end")
       let b = sourceBlob "method.rb" (Just Ruby) (Source "def bar(x); end")
@@ -43,6 +43,17 @@ spec = parallel $ do
       h <- openFile "test/fixtures/input/blank.json" ReadMode
       runCommand (readBlobPairsFromHandle 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) (Source "def foo; end")
+      blobs `shouldBe` [a]
+
+    it "throws on invalid 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.json

@@ -2,10 +2,12 @@
   "blobs": [{
     "path": "method.rb",
     "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,6 @@
+{
+  "blobs": [{
+    "path": "method.rb",
+    "content": "def foo; end",
+    "language": "Ruby"  }]
+}