From 5253b138464d5cbc053021f9e26729a86b07c8d6 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 11 May 2017 16:15:48 -0700 Subject: [PATCH] Read JSON encoded blob content on stdin --- src/Arguments.hs | 2 +- src/Command.hs | 7 ++++++ src/Command/Files.hs | 49 ++++++++++++++++++++++++++++++++++++++++++ src/SemanticCmdLine.hs | 8 ++++--- 4 files changed, 62 insertions(+), 4 deletions(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index 43ad9e835..cf8d3a559 100644 --- a/src/Arguments.hs +++ b/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 diff --git a/src/Command.hs b/src/Command.hs index 010e33759..316d94165 100644 --- a/src/Command.hs +++ b/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 '_' diff --git a/src/Command/Files.hs b/src/Command/Files.hs index dee818d47..29c905da9 100644 --- a/src/Command/Files.hs +++ b/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) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index ae7043bc4..331bc82b2 100644 --- a/src/SemanticCmdLine.hs +++ b/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) - 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 -> 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 )