Read JSON encoded blob content on stdin

src/Arguments.hs

@@ -10,7 +10,7 @@ import Renderer
 import Renderer.SExpression
 import Info
 
-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

src/Command.hs

@@ -3,6 +3,7 @@ module Command
 ( Command
 -- Constructors
 , readFile
+, readStdin
 , readFilesAtSHA
 , readFilesAtSHAs
 -- Evaluation
@@ -32,6 +33,9 @@ type Command = Freer CommandF
 readFile :: FilePath -> Maybe Language -> Command SourceBlob
 readFile path lang = ReadFile path lang `Then` return
 
+readStdin :: Command [Both SourceBlob]
+readStdin = ReadStdin `Then` return
+
 -- | Read a list of files at the given commit SHA.
 readFilesAtSHA :: FilePath -- ^ GIT_DIR
                 -> [FilePath] -- ^ GIT_ALTERNATE_OBJECT_DIRECTORIES
@@ -55,6 +59,7 @@ 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
+  ReadStdin -> Files.readStdin >>= 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 +69,7 @@ runCommand = iterFreerA $ \ command yield -> case command of
 
 data CommandF f where
   ReadFile :: FilePath -> Maybe Language -> CommandF SourceBlob
+  ReadStdin :: CommandF [Both 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 +80,7 @@ instance MonadIO Command where
 instance Show1 CommandF where
   liftShowsPrec _ _ d command = case command of
     ReadFile path lang -> showsBinaryWith showsPrec showsPrec "ReadFile" d path lang
+    ReadStdin -> showString "ReadStdin"
     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,7 +1,9 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveGeneric, DeriveAnyClass, TypeSynonymInstances #-}
 module Command.Files
 ( readFile
 , transcode
 , languageForFilePath
+, readStdin
 ) where
 
 import Prologue hiding (readFile)
@@ -13,6 +15,11 @@ 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.String
+import Data.Aeson
+import Data.Functor.Both
+
 -- | Read a file to a SourceBlob, transcoding to UTF-8 along the way.
 readFile :: FilePath -> Maybe Language -> IO SourceBlob
 readFile path language = do
@@ -30,3 +37,45 @@ 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
+
+
+-- PROTOTYPE
+
+readStdin :: IO [Both SourceBlob]
+readStdin = do
+  input <- B.getContents
+  let request = decode (toS input) :: Maybe DiffRequest
+  pure $ maybe mempty sourceBlobs request
+
+
+newtype DiffRequest = DiffRequest
+  { blobs :: [BlobPair]
+  } deriving (Show, Generic, FromJSON, ToJSON)
+
+data BlobPair = BlobPair
+  { path :: String
+  , before :: Maybe BlobContent
+  , after :: Maybe BlobContent
+  } deriving (Show, Generic, FromJSON, ToJSON)
+
+newtype BlobContent = BlobContent { utf8Text :: ByteString }
+  deriving (Eq, Show)
+
+instance ToJSON BlobContent where
+  toJSON = String . decodeUtf8 . utf8Text
+
+instance FromJSON BlobContent where
+  parseJSON (String t) = (pure . BlobContent . encodeUtf8) t
+  parseJSON _ = A.empty
+
+sourceBlobs :: DiffRequest -> [Both SourceBlob]
+sourceBlobs DiffRequest{..} = toSourceBlob <$> blobs
+  where
+    toSourceBlob :: BlobPair -> Both SourceBlob
+    toSourceBlob BlobPair{..} = fmap (sourceBlob' path) (both before after)
+
+    sourceBlob' :: FilePath -> Maybe BlobContent -> SourceBlob
+    sourceBlob' path maybeContent = maybe (emptySourceBlob path) (sourceBlob path (languageForFilePath path)) (source' maybeContent)
+
+    source' :: Maybe BlobContent -> Maybe Source
+    source' = fmap (Source . utf8Text)

src/SemanticCmdLine.hs

@@ -48,8 +48,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)
+    DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b)
-   DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+    DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+    DiffStdin -> readStdin
   Semantic.diffBlobPairs diffRenderer blobs
 
 runParse :: ParseArguments -> IO ByteString
@@ -85,7 +86,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 )