2017-03-31 22:10:16 +03:00
|
|
|
{-# LANGUAGE DataKinds, GADTs #-}
|
2017-03-31 18:52:51 +03:00
|
|
|
module Command
|
2017-04-03 19:18:48 +03:00
|
|
|
( Command
|
|
|
|
-- Constructors
|
|
|
|
, readFile
|
|
|
|
, readFilesAtSHAs
|
|
|
|
, parse
|
2017-04-03 22:13:37 +03:00
|
|
|
, parseBlob
|
2017-04-03 19:18:48 +03:00
|
|
|
, diff
|
|
|
|
, renderDiff
|
2017-04-03 22:12:00 +03:00
|
|
|
, renderDiffOutput
|
2017-04-03 19:18:48 +03:00
|
|
|
-- Evaluation
|
|
|
|
, runCommand
|
2017-03-31 18:52:51 +03:00
|
|
|
) where
|
|
|
|
|
2017-04-03 19:18:48 +03:00
|
|
|
import Command.Parse
|
2017-03-31 19:58:17 +03:00
|
|
|
import Control.Monad.Free.Freer
|
2017-04-01 00:03:17 +03:00
|
|
|
import Data.Functor.Both
|
2017-03-31 22:53:49 +03:00
|
|
|
import Data.List ((\\))
|
2017-03-31 22:45:33 +03:00
|
|
|
import Data.RandomWalkSimilarity
|
2017-03-31 22:10:16 +03:00
|
|
|
import Data.Record
|
2017-03-31 21:28:36 +03:00
|
|
|
import Data.String
|
|
|
|
import Debug.Trace (traceEventIO)
|
2017-03-31 22:33:24 +03:00
|
|
|
import Diff
|
2017-03-31 22:10:16 +03:00
|
|
|
import Info
|
2017-03-31 22:45:33 +03:00
|
|
|
import Interpreter
|
2017-03-31 21:28:36 +03:00
|
|
|
import qualified Git
|
|
|
|
import Git.Blob
|
|
|
|
import Git.Libgit2
|
2017-04-03 19:04:54 +03:00
|
|
|
import Git.Libgit2.Backend
|
2017-03-31 21:28:36 +03:00
|
|
|
import Git.Repository
|
|
|
|
import Git.Types
|
|
|
|
import GitmonClient
|
2017-03-31 22:10:16 +03:00
|
|
|
import Language
|
2017-04-03 19:18:48 +03:00
|
|
|
import Prologue hiding (readFile)
|
2017-04-01 00:03:17 +03:00
|
|
|
import Renderer
|
2017-03-31 19:58:17 +03:00
|
|
|
import Source
|
2017-03-31 22:10:16 +03:00
|
|
|
import Syntax
|
2017-04-03 22:13:37 +03:00
|
|
|
import System.FilePath
|
2017-03-31 22:10:16 +03:00
|
|
|
import Term
|
2017-03-31 19:58:17 +03:00
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
|
|
|
|
-- | High-level commands encapsulating the work done to perform a diff or parse operation.
|
2017-03-31 19:58:17 +03:00
|
|
|
type Command = Freer CommandF
|
2017-03-31 19:58:27 +03:00
|
|
|
|
2017-03-31 22:29:15 +03:00
|
|
|
|
2017-04-03 19:09:05 +03:00
|
|
|
-- Constructors
|
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
-- | Read a regular file into a SourceBlob.
|
2017-04-03 19:09:05 +03:00
|
|
|
readFile :: FilePath -> Command SourceBlob
|
|
|
|
readFile path = ReadFile path `Then` return
|
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
-- | Read a list of files at the states corresponding to the given shas.
|
|
|
|
readFilesAtSHAs
|
|
|
|
:: FilePath -- ^ GIT_DIR
|
|
|
|
-> [FilePath] -- ^ GIT_ALTERNATE_OBJECT_DIRECTORIES
|
|
|
|
-> [FilePath] -- ^ Specific paths to diff. If empty, diff all changed paths.
|
|
|
|
-> String -- ^ The commit sha for the before state.
|
|
|
|
-> String -- ^ The commit sha for the after state.
|
|
|
|
-> Command [(SourceBlob, SourceBlob)] -- ^ A command producing a list of pairs of blobs for the specified files (or all files if none were specified).
|
2017-04-03 19:09:05 +03:00
|
|
|
readFilesAtSHAs gitDir alternateObjectDirs paths sha1 sha2 = ReadFilesAtSHAs gitDir alternateObjectDirs paths sha1 sha2 `Then` return
|
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
-- | Parse a blob in a given language.
|
2017-04-03 21:37:53 +03:00
|
|
|
parse :: Maybe Language -> SourceBlob -> Command (Term (Syntax Text) (Record DefaultFields))
|
2017-04-03 19:09:05 +03:00
|
|
|
parse language blob = Parse language blob `Then` return
|
|
|
|
|
2017-04-03 22:13:37 +03:00
|
|
|
-- | Parse a blob in the language selected for its file extension.
|
|
|
|
parseBlob :: SourceBlob -> Command (Term (Syntax Text) (Record DefaultFields))
|
|
|
|
parseBlob blob = parse (languageForType (takeExtension (path blob))) blob
|
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
-- | Diff two terms.
|
2017-04-03 19:32:36 +03:00
|
|
|
diff :: HasField fields Category => Term (Syntax Text) (Record fields) -> Term (Syntax Text) (Record fields) -> Command (Diff (Syntax Text) (Record fields))
|
2017-04-03 19:09:05 +03:00
|
|
|
diff term1 term2 = Diff term1 term2 `Then` return
|
|
|
|
|
2017-04-03 19:28:43 +03:00
|
|
|
-- | Render a diff using the specified renderer.
|
2017-04-03 19:09:05 +03:00
|
|
|
renderDiff :: DiffRenderer fields output -> SourceBlob -> SourceBlob -> Diff (Syntax Text) (Record fields) -> Command output
|
|
|
|
renderDiff renderer blob1 blob2 diff = RenderDiff renderer blob1 blob2 diff `Then` return
|
|
|
|
|
2017-04-03 22:12:00 +03:00
|
|
|
-- | Render a diff using the specified renderer, wrapping the result up in Output.
|
|
|
|
renderDiffOutput :: DiffRenderer fields output -> SourceBlob -> SourceBlob -> Diff (Syntax Text) (Record fields) -> Command Output
|
|
|
|
renderDiffOutput renderer blob1 blob2 diff = fmap output (renderDiff renderer blob1 blob2 diff)
|
|
|
|
where output = case renderer of
|
|
|
|
SplitRenderer -> SplitOutput
|
|
|
|
PatchRenderer -> PatchOutput
|
|
|
|
JSONDiffRenderer -> JSONOutput
|
|
|
|
SummaryRenderer -> SummaryOutput
|
|
|
|
SExpressionDiffRenderer _ -> SExpressionOutput
|
|
|
|
ToCRenderer -> TOCOutput
|
|
|
|
|
2017-04-03 19:09:05 +03:00
|
|
|
|
2017-03-31 22:29:15 +03:00
|
|
|
-- Evaluation
|
|
|
|
|
2017-04-03 19:29:14 +03:00
|
|
|
-- | Run the passed command and return its results in IO.
|
2017-03-31 19:58:27 +03:00
|
|
|
runCommand :: Command a -> IO a
|
|
|
|
runCommand = iterFreerA $ \ command yield -> case command of
|
2017-04-03 19:02:40 +03:00
|
|
|
ReadFile path -> runReadFile path >>= yield
|
2017-04-03 19:04:54 +03:00
|
|
|
ReadFilesAtSHAs gitDir alternateObjectDirs paths sha1 sha2 -> runReadFilesAtSHAs gitDir alternateObjectDirs paths sha1 sha2 >>= yield
|
2017-04-03 19:02:40 +03:00
|
|
|
Parse language blob -> runParse language blob >>= yield
|
|
|
|
Diff term1 term2 -> yield (runDiff term1 term2)
|
|
|
|
RenderDiff renderer blob1 blob2 diff -> yield (runRenderDiff renderer blob1 blob2 diff)
|
|
|
|
|
2017-04-03 19:09:59 +03:00
|
|
|
|
|
|
|
-- Implementation details
|
|
|
|
|
|
|
|
data CommandF f where
|
|
|
|
ReadFile :: FilePath -> CommandF SourceBlob
|
|
|
|
ReadFilesAtSHAs :: FilePath -> [FilePath] -> [FilePath] -> String -> String -> CommandF [(SourceBlob, SourceBlob)]
|
|
|
|
|
2017-04-03 21:37:53 +03:00
|
|
|
Parse :: Maybe Language -> SourceBlob -> CommandF (Term (Syntax Text) (Record DefaultFields))
|
2017-04-03 19:09:59 +03:00
|
|
|
|
2017-04-03 19:32:36 +03:00
|
|
|
Diff :: HasField fields Category => Term (Syntax Text) (Record fields) -> Term (Syntax Text) (Record fields) -> CommandF (Diff (Syntax Text) (Record fields))
|
2017-04-03 19:09:59 +03:00
|
|
|
|
|
|
|
RenderDiff :: DiffRenderer fields output -> SourceBlob -> SourceBlob -> Diff (Syntax Text) (Record fields) -> CommandF output
|
|
|
|
|
2017-04-03 19:33:53 +03:00
|
|
|
-- TODO: parallelize diffs of a list of paths + git shas?
|
2017-04-03 19:09:59 +03:00
|
|
|
|
|
|
|
|
2017-04-03 19:02:40 +03:00
|
|
|
runReadFile :: FilePath -> IO SourceBlob
|
|
|
|
runReadFile path = do
|
|
|
|
source <- readAndTranscodeFile path
|
|
|
|
return (sourceBlob source path)
|
|
|
|
|
2017-04-03 19:04:54 +03:00
|
|
|
runReadFilesAtSHAs :: FilePath -> [FilePath] -> [FilePath] -> String -> String -> IO [(SourceBlob, SourceBlob)]
|
|
|
|
runReadFilesAtSHAs gitDir alternateObjectDirs paths sha1 sha2 = withRepository lgFactory gitDir $ do
|
|
|
|
repo <- getRepository
|
|
|
|
for_ alternateObjectDirs (liftIO . odbBackendAddPath repo . toS)
|
2017-04-03 19:02:40 +03:00
|
|
|
|
|
|
|
liftIO $ traceEventIO ("START readFilesAtSHAs: " <> show paths)
|
|
|
|
|
|
|
|
tree1 <- treeForSha sha1
|
|
|
|
tree2 <- treeForSha sha2
|
|
|
|
|
|
|
|
paths <- case paths of
|
|
|
|
(_ : _) -> pure paths
|
|
|
|
[] -> do
|
|
|
|
a <- pathsForTree tree1
|
|
|
|
b <- pathsForTree tree2
|
|
|
|
|
|
|
|
pure $! (a \\ b) <> (b \\ a)
|
|
|
|
|
|
|
|
blobs <- for paths $ \ path -> (,) <$> blobForPathInTree path tree1 <*> blobForPathInTree path tree2
|
|
|
|
|
|
|
|
liftIO $! traceEventIO ("END readFilesAtSHAs: " <> show paths)
|
|
|
|
return blobs
|
|
|
|
where treeForSha sha = do
|
|
|
|
obj <- parseObjOid (toS sha)
|
|
|
|
commit <- reportGitmon "cat-file" $ lookupCommit obj
|
|
|
|
reportGitmon "cat-file" $ lookupTree (commitTree commit)
|
|
|
|
blobForPathInTree path tree = do
|
|
|
|
entry <- reportGitmon "ls-tree" $ treeEntry tree (toS path)
|
|
|
|
case entry of
|
|
|
|
Just (BlobEntry entryOid entryKind) -> do
|
|
|
|
blob <- reportGitmon "cat-file" $ lookupBlob entryOid
|
|
|
|
contents <- blobToByteString blob
|
|
|
|
transcoded <- liftIO $ transcode contents
|
|
|
|
let oid = renderObjOid $ blobOid blob
|
|
|
|
pure $! SourceBlob transcoded (toS oid) path (Just (toSourceKind entryKind))
|
|
|
|
_ -> pure $! emptySourceBlob path
|
|
|
|
pathsForTree tree = do
|
|
|
|
blobEntries <- reportGitmon "ls-tree" $ treeBlobEntries tree
|
|
|
|
return $! fmap (\ (p, _, _) -> toS p) blobEntries
|
|
|
|
|
|
|
|
toSourceKind (Git.PlainBlob mode) = Source.PlainBlob mode
|
|
|
|
toSourceKind (Git.ExecutableBlob mode) = Source.ExecutableBlob mode
|
|
|
|
toSourceKind (Git.SymlinkBlob mode) = Source.SymlinkBlob mode
|
|
|
|
|
2017-04-03 21:37:53 +03:00
|
|
|
runParse :: Maybe Language -> SourceBlob -> IO (Term (Syntax Text) (Record DefaultFields))
|
|
|
|
runParse language = maybe lineByLineParser parserForLanguage language
|
2017-04-03 19:02:40 +03:00
|
|
|
|
2017-04-03 19:32:36 +03:00
|
|
|
runDiff :: HasField fields Category => Term (Syntax Text) (Record fields) -> Term (Syntax Text) (Record fields) -> Diff (Syntax Text) (Record fields)
|
2017-04-03 19:02:40 +03:00
|
|
|
runDiff term1 term2 = stripDiff (diffTerms (decorate term1) (decorate term2))
|
|
|
|
where decorate = defaultFeatureVectorDecorator getLabel
|
2017-04-03 19:32:36 +03:00
|
|
|
getLabel :: HasField fields Category => TermF (Syntax Text) (Record fields) a -> (Category, Maybe Text)
|
2017-04-03 19:02:40 +03:00
|
|
|
getLabel (h :< t) = (Info.category h, case t of
|
|
|
|
Leaf s -> Just s
|
|
|
|
_ -> Nothing)
|
|
|
|
|
|
|
|
runRenderDiff :: DiffRenderer fields output -> SourceBlob -> SourceBlob -> Diff (Syntax Text) (Record fields) -> output
|
2017-04-03 19:05:52 +03:00
|
|
|
runRenderDiff renderer = (runDiffRenderer' renderer .) . both
|