Merge branch 'master' into ruby-assignment-a-la-carte

2024-12-25 07:55:12 +03:00 · 2017-04-20 15:25:34 -04:00 · 2017-04-20 15:25:34 -04:00 · 085839aabf
commit 085839aabf
parent ccf9fa9ee2 831c55d025
16 changed files with 307 additions and 418 deletions
--- a/.atom-build.yml
+++ b/.atom-build.yml
@ -1,11 +0,0 @@
-# Build configuration for https://atom.io/packages/build
-cmd: stack build
-name: semantic-diff
-env:
-  PATH: ~/.local/bin:~/Developer/Tools:~/Library/Haskell/bin:/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin
-targets:
-  test:
-    cmd: stack build semantic-diff:test
-    keymap: cmd-u
-errorMatch:
- \n(?<file>/[^:]+):(?<line>\d+):((?<col>\d+):)?
--- a/app/Main.hs
+++ b/app/Main.hs
@ -1,3 +1,3 @@
 module Main (main)
 where
-import SemanticDiff (main)
+import Semantic (main)
--- a/bench/Main.hs
+++ b/bench/Main.hs
@ -1,67 +0,0 @@
-{-# LANGUAGE DeriveAnyClass, FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Main where
-
-import Arguments
-import Criterion.Main
-import Data.Function
-import Data.List (genericLength)
-import Data.String
-import Patch
-import Prologue
-import qualified Renderer as R
-import SemanticDiff (fetchDiffs)
-import qualified SemanticDiffPar
-import SES
-import System.Directory (makeAbsolute)
-
-main :: IO ()
-main = defaultMain
-  [ bgroup "ses"
-    [ bench "0,0" (nf (uncurry benchmarkSES) ([], []))
-    , bench "1,1, =" (nf (uncurry benchmarkSES) ([lower], [lower]))
-    , bench "1,1, ≠" (nf (uncurry benchmarkSES) ([lower], [upper]))
-    , bench "10,10, =" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 lower))
-    , bench "10,10, ≠" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 upper))
-    , bench "100,100, =" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 lower))
-    , bench "100,100, ≠" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 upper))
-    ]
-  , syncAsyncBenchmark
-  ]
-  where lower = ['a'..'z']
-        upper = ['A'..'Z']
-
-benchmarkSES :: [String] -> [String] -> [Either String (Patch String)]
-benchmarkSES = ses compare cost
-  where compare a b = if a == b then Just (Left a) else Nothing
-        cost = either (const 0) (sum . fmap genericLength)
-
-instance NFData a => NFData (Patch a)
-
-syncAsyncBenchmark :: Benchmark
-syncAsyncBenchmark =
-  bgroup "async vs par" [
-      bench "async" . whnfIO $ SemanticDiff.fetchDiffs =<< theArgs,
-      bench "par" . whnfIO $ SemanticDiffPar.fetchDiffs =<< theArgs
-    ]
-
-theArgs :: IO Arguments
-theArgs = do
-  jqueryPath <- makeAbsolute "test/repos/jquery"
-  pure $ args jqueryPath sha1 sha2 files R.Patch
-  where
-    sha1 = "70526981916945dc4093e116a3de61b1777d4718"
-    sha2 = "e5ffcb0838c894e26f4ff32dfec162cf624d8d7d"
-    files = [
-            "src/manipulation/getAll.js",
-            "src/manipulation/support.js",
-            "src/manipulation/wrapMap.js",
-            "src/offset.js",
-            "test/unit/css.js",
-            "test/unit/deferred.js",
-            "test/unit/deprecated.js",
-            "test/unit/effects.js",
-            "test/unit/event.js",
-            "test/unit/offset.js",
-            "test/unit/wrap.js"
-            ]
--- a/bench/SemanticDiffPar.hs
+++ b/bench/SemanticDiffPar.hs
@ -1,12 +0,0 @@
-module SemanticDiffPar where
-
-import Arguments
-import qualified Control.Monad.Par.IO as ParIO
-import Control.Monad.Reader
-import qualified Data.Text as T
-import Prologue
-import qualified Renderer as R
-import SemanticDiff
-
-fetchDiffs :: Arguments -> IO [T.Text]
-fetchDiffs args@Arguments{..} = pure . pure . R.concatOutputs =<< (ParIO.runParIO . liftIO $ for filePaths (fetchDiff args))
--- a/script/generate-example
+++ b/script/generate-example
@ -40,28 +40,28 @@ generate_example () {
  diffFileBA="${fileB%%.*}.diffB-A.txt"

  status $parseFileA
-  stack exec semantic-diff -- --sexpression --parse $fileA > $parseFileA
+  stack exec semantic parse -- --sexpression $fileA > $parseFileA

  status $parseFileB
-  stack exec semantic-diff -- --sexpression --parse $fileB > $parseFileB
+  stack exec semantic parse -- --sexpression $fileB > $parseFileB

  status $diffFileAddA
-  stack exec semantic-diff -- --sexpression --no-index /dev/null $fileA > $diffFileAddA
+  stack exec semantic diff -- --sexpression /dev/null $fileA > $diffFileAddA

  status $diffFileRemoveA
-  stack exec semantic-diff -- --sexpression --no-index $fileA /dev/null > $diffFileRemoveA
+  stack exec semantic diff -- --sexpression $fileA /dev/null > $diffFileRemoveA

  status $diffFileAddB
-  stack exec semantic-diff -- --sexpression --no-index /dev/null $fileB > $diffFileAddB
+  stack exec semantic diff -- --sexpression --no-index /dev/null $fileB > $diffFileAddB

  status $diffFileRemoveB
-  stack exec semantic-diff -- --sexpression --no-index $fileB /dev/null > $diffFileRemoveB
+  stack exec semantic diff -- --sexpression $fileB /dev/null > $diffFileRemoveB

  status $diffFileAB
-  stack exec semantic-diff -- --sexpression --no-index $fileA $fileB > $diffFileAB
+  stack exec semantic diff -- --sexpression $fileA $fileB > $diffFileAB

  status $diffFileBA
-  stack exec semantic-diff -- --sexpression --no-index $fileB $fileA > $diffFileBA
+  stack exec semantic diff -- --sexpression $fileB $fileA > $diffFileBA
 }

 if [[ -d $1 ]]; then
--- a/semantic-diff.cabal
+++ b/semantic-diff.cabal
@ -1,5 +1,5 @@
 name:                semantic-diff
-version:             0.2.0
+version:             0.3.0
 synopsis:            Initial project template from stack
 description:         Please see README.md
 homepage:            http://github.com/github/semantic-diff#readme
@ -63,7 +63,7 @@ library
                     , Renderer.Summary
                     , Renderer.SExpression
                     , Renderer.TOC
-                     , SemanticDiff
+                     , Semantic
                     , SES
                     , SES.Myers
                     , Source
@ -130,7 +130,7 @@ library
  ghc-options:        -Wall -fno-warn-name-shadowing -O2 -j
  ghc-prof-options: -fprof-auto

-executable semantic-diff
+executable semantic
  hs-source-dirs:      app
  main-is:             Main.hs
  ghc-options:       -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O2 -pgml=script/g++
@ -141,23 +141,6 @@ executable semantic-diff
  default-language:    Haskell2010
  default-extensions:  FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards

-benchmark semantic-diff-bench
-  type:                exitcode-stdio-1.0
-  main-is:             Main.hs
-  hs-source-dirs:      bench
-  other-modules:       SemanticDiffPar
-  build-depends:       base
-                     , criterion
-                     , directory
-                     , leancheck
-                     , monad-par
-                     , mtl
-                     , semantic-diff
-                     , text >= 1.2.1.3
-  ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j -O2 -static -pgml=script/g++
-  default-language:    Haskell2010
-  default-extensions:  FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards
-
 test-suite test
  type:                exitcode-stdio-1.0
  hs-source-dirs:      test
@ -170,6 +153,7 @@ test-suite test
                     , Data.RandomWalkSimilarity.Spec
                     , Data.Syntax.Assignment.Spec
                     , DiffSpec
+                     , SemanticSpec
                     , SummarySpec
                     , GitmonClientSpec
                     , InterpreterSpec
--- a/src/Arguments.hs
+++ b/src/Arguments.hs
@ -1,153 +1,37 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
-module Arguments (Arguments(..), CmdLineOptions(..), DiffMode(..), ExtraArg(..), RunMode(..), programArguments, args, diffPathsArgs, parseArgs) where
+module Arguments where

-import Data.Functor.Both
+import Command
 import Data.Maybe
-import Data.List.Split
-import Prologue hiding ((<>))
 import Prelude
-import System.Environment
-import System.Directory
-import System.FilePath.Posix (takeFileName, (-<.>))
-import System.IO.Error (IOError)

-import qualified Renderer as R

-data ExtraArg = ShaPair (Both (Maybe String))
-              | FileArg FilePath
-              deriving (Show)
+data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath
+  deriving Show

-data DiffMode = PathDiff (Both FilePath)
-              | CommitDiff
-              deriving (Show)
-
-data RunMode = Diff
-             | Parse
-             deriving (Show)
-
-- | The command line options to the application (arguments for optparse-applicative).
-data CmdLineOptions = CmdLineOptions
-  { outputFormat :: R.Format
-  , maybeTimeout :: Maybe Float
-  , outputFilePath :: Maybe FilePath
-  , commitSha' :: Maybe String
-  , noIndex :: Bool
-  , extraArgs :: [ExtraArg]
-  , debug' :: Bool
-  , runMode' :: RunMode
-  }
-
-- | Arguments for the program (includes command line, environment, and defaults).
-data Arguments = Arguments
-  { gitDir :: FilePath
-  , alternateObjectDirs :: [FilePath]
-  , format :: R.Format
-  , timeoutInMicroseconds :: Int
-  , outputPath :: Maybe FilePath
-  , commitSha :: Maybe String
+data DiffArguments = DiffArguments
+  { encodeDiff :: DiffEncoder
  , diffMode :: DiffMode
-  , runMode :: RunMode
-  , shaRange :: Both (Maybe String)
-  , filePaths :: [FilePath]
+  , gitDir :: FilePath
+  , alternateObjectDirs :: [FilePath]
+  } deriving Show
+
+data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath]
+  deriving Show
+
+data ParseArguments = ParseArguments
+  { renderParseTree :: ParseTreeRenderer
+  , parseMode :: ParseMode
  , debug :: Bool
-  } deriving (Show)
+  , gitDir :: FilePath
+  , alternateObjectDirs :: [FilePath]
+  } deriving Show

-- | Returns Arguments for the program from parsed command line arguments.
-programArguments :: CmdLineOptions -> IO Arguments
-programArguments CmdLineOptions{..} = do
-  pwd <- getCurrentDirectory
-  gitDir <- fromMaybe pwd <$> lookupEnv "GIT_DIR"
-  eitherObjectDirs <- try $ parseObjectDirs . toS <$> getEnv "GIT_ALTERNATE_OBJECT_DIRECTORIES"
-  outputPath <- getOutputPath outputFilePath
-  let alternateObjectDirs = case (eitherObjectDirs :: Either IOError [FilePath]) of
-                              (Left _) -> []
-                              (Right objectDirs) -> objectDirs
+data ProgramMode = Parse ParseArguments | Diff DiffArguments
+  deriving Show

-  let filePaths = fetchPaths extraArgs
-  pure Arguments
-    { gitDir = gitDir
-    , alternateObjectDirs = alternateObjectDirs
-    , format = outputFormat
-    , timeoutInMicroseconds = maybe defaultTimeout toMicroseconds maybeTimeout
-    , outputPath = outputPath
-    , commitSha = commitSha'
-    , diffMode = case (noIndex, filePaths) of
-      (True, [fileA, fileB]) -> PathDiff (both fileA fileB)
-      (_, _) -> CommitDiff
-    , runMode = runMode'
-    , shaRange = fetchShas extraArgs
-    , filePaths = filePaths
-    , debug = debug'
-    }
-  where
-    fetchPaths :: [ExtraArg] -> [FilePath]
-    fetchPaths [] = []
-    fetchPaths (FileArg x:xs) = x : fetchPaths xs
-    fetchPaths (_:xs) = fetchPaths xs
-
-    fetchShas :: [ExtraArg] -> Both (Maybe String)
-    fetchShas [] = both Nothing Nothing
-    fetchShas (ShaPair x:_) = x
-    fetchShas (_:xs) = fetchShas xs
-
-    getOutputPath Nothing = pure Nothing
-    getOutputPath (Just path) = do
-      isDir <- doesDirectoryExist path
-      pure . Just $ if isDir then takeFileName path -<.> ".html" else path
-
-
-- | Quickly assemble an Arguments data record with defaults.
-args :: FilePath -> String -> String -> [String] -> R.Format -> Arguments
-args gitDir sha1 sha2 filePaths format = Arguments
-  { gitDir = gitDir
-  , alternateObjectDirs = []
-  , format = format
-  , timeoutInMicroseconds = defaultTimeout
-  , outputPath = Nothing
-  , commitSha = Nothing
-  , diffMode = CommitDiff
-  , runMode = Diff
-  , shaRange = Just <$> both sha1 sha2
-  , filePaths = filePaths
-  , debug = False
-  }
-
-diffPathsArgs :: FilePath -> Both FilePath -> R.Format -> Arguments
-diffPathsArgs gitDir paths format = Arguments
-  { gitDir = gitDir
-  , alternateObjectDirs = []
-  , format = format
-  , timeoutInMicroseconds = defaultTimeout
-  , outputPath = Nothing
-  , commitSha = Nothing
-  , diffMode = PathDiff paths
-  , runMode = Diff
-  , shaRange = both Nothing Nothing
-  , filePaths = []
-  , debug = False
-  }
-
-parseArgs :: [String] -> R.Format -> Arguments
-parseArgs filePaths format = Arguments
-  { gitDir = ""
-  , alternateObjectDirs = []
-  , format = format
-  , timeoutInMicroseconds = defaultTimeout
-  , outputPath = Nothing
-  , commitSha = Nothing
-  , diffMode = CommitDiff
-  , runMode = Parse
-  , shaRange = both Nothing Nothing
-  , filePaths = filePaths
-  , debug = False
-  }
-
-- | 7 seconds
-defaultTimeout :: Int
-defaultTimeout = 7 * 1000000
-
-toMicroseconds :: Float -> Int
-toMicroseconds num = floor $ num * 1000000
-
-parseObjectDirs :: FilePath -> [FilePath]
-parseObjectDirs = splitWhen (== ':')
+data Arguments = Arguments
+  { programMode :: ProgramMode
+  , outputFilePath :: Maybe FilePath
+  } deriving Show
--- a/src/Command.hs
+++ b/src/Command.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, GADTs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Command
 ( Command
 -- Constructors
@ -10,6 +11,14 @@ module Command
 , maybeDiff
 , renderDiffs
 , concurrently
+, patchDiff
+, splitDiff
+, jsonDiff
+, summaryDiff
+, sExpressionDiff
+, tocDiff
+, DiffEncoder
+, ParseTreeRenderer
 -- Evaluation
 , runCommand
 ) where
@ -20,15 +29,16 @@ import Control.Exception (catch)
 import Control.Monad.Free.Freer
 import Control.Monad.IO.Class
 import Control.Parallel.Strategies
+import Data.Aeson hiding (json)
 import qualified Data.ByteString as B
 import Data.Functor.Both
+import Data.Functor.Classes
+import Data.Functor.Listable
 import Data.List ((\\), nub)
 import Data.RandomWalkSimilarity
 import Data.Record
 import Data.String
 import Diff
-import Info
-import Interpreter
 import GHC.Conc (numCapabilities)
 import qualified Git
 import Git.Blob
@ -37,14 +47,19 @@ import Git.Libgit2.Backend
 import Git.Repository
 import Git.Types
 import GitmonClient
+import Info
+import Interpreter
 import Language
 import Patch
 import Prologue hiding (concurrently, Concurrently, readFile)
+import qualified Renderer as R
+import qualified Renderer.SExpression as R
 import Renderer
 import Source
 import Syntax
 import System.FilePath
 import Term
+import Text.Show


 -- | High-level commands encapsulating the work done to perform a diff or parse operation.
@ -188,5 +203,69 @@ runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBl
 runRenderDiffs = runDiffRenderer


+type ParseTreeRenderer = Bool -> [SourceBlob] -> IO ByteString
+
+type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
+
+patchDiff :: DiffEncoder
+patchDiff = fmap encodeText . renderDiffs R.PatchRenderer
+
+splitDiff :: DiffEncoder
+splitDiff = fmap encodeText . renderDiffs R.SplitRenderer
+
+jsonDiff :: DiffEncoder
+jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer
+
+summaryDiff :: DiffEncoder
+summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer
+
+sExpressionDiff :: DiffEncoder
+sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
+
+tocDiff :: DiffEncoder
+tocDiff = fmap encodeSummaries . renderDiffs R.ToCRenderer
+
+encodeJSON :: Map Text Value -> ByteString
+encodeJSON = toS . (<> "\n") . encode
+
+encodeText :: File -> ByteString
+encodeText = encodeUtf8 . R.unFile
+
+encodeSummaries :: Summaries -> ByteString
+encodeSummaries = toS . (<> "\n") . encode
+
+
+instance Show ParseTreeRenderer where
+  showsPrec d _ = showParen (d >= 10) $ showString "ParseTreeRenderer "
+
+instance Listable ParseTreeRenderer where
+  tiers = cons0 jsonParseTree
+       \/ cons0 jsonIndexParseTree
+       \/ cons0 sExpressionParseTree
+
+instance Show DiffEncoder where
+  showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "
+    . showsPrec 10 (encodeDiff []) . showChar ' '
+
+instance Listable DiffEncoder where
+  tiers = cons0 patchDiff
+       \/ cons0 splitDiff
+       \/ cons0 jsonDiff
+       \/ cons0 summaryDiff
+       \/ cons0 sExpressionDiff
+       \/ cons0 tocDiff
+
 instance MonadIO Command where
  liftIO io = LiftIO io `Then` return
+
+instance Show1 CommandF where
+  liftShowsPrec sp sl d command = case command of
+    ReadFile path -> showsUnaryWith showsPrec "ReadFile" d path
+    ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas
+      where showsQuaternaryWith sp1 sp2 sp3 sp4 name d x y z w = showParen (d > 10) $
+              showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y . showChar ' ' . sp3 11 z . showChar ' ' . sp4 11 w
+    Parse language _ -> showsBinaryWith showsPrec (const showChar) "Parse" d language '_'
+    Diff _ -> showsUnaryWith (const showChar) "Diff" d '_'
+    RenderDiffs renderer _ -> showsBinaryWith showsPrec (const showChar) "RenderDiffs" d renderer '_'
+    Concurrently commands f -> showsBinaryWith (liftShowsPrec sp sl) (const showChar) "Concurrently" d (traverse f commands) '_'
+    LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_'
--- a/src/Command/Parse.hs
+++ b/src/Command/Parse.hs
@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module Command.Parse where

-import Arguments
 import Category
 import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
 import Data.Aeson.Types (Pair)
@ -65,19 +64,17 @@ parseNodeToJSONFields ParseNode{..} =
  <> [ "identifier" .= identifier | isJust identifier ]

 -- | Parses file contents into an SExpression format for the provided arguments.
-parseSExpression :: Arguments -> IO ByteString
-parseSExpression =
-  pure . printTerms TreeOnly <=< parse <=< sourceBlobsFromArgs
+sExpressionParseTree :: Bool -> [SourceBlob] -> IO ByteString
+sExpressionParseTree _ blobs =
+  pure . printTerms TreeOnly =<< parse blobs
  where parse = traverse (\sourceBlob@SourceBlob{..} -> parserForType (toS (takeExtension path)) sourceBlob)

 type RAlgebra t a = Base t (t, a) -> a

-parseRoot :: (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> Arguments -> IO [root]
-parseRoot construct combine args@Arguments{..} = do
-  blobs <- sourceBlobsFromArgs args
-  for blobs (\ sourceBlob@SourceBlob{..} -> do
-    parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
-    pure $! construct path (para algebra parsedTerm))
+parseRoot :: Bool -> (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> [SourceBlob] -> IO [root]
+parseRoot debug construct combine blobs = for blobs (\ sourceBlob@SourceBlob{..} -> do
+  parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
+  pure $! construct path (para algebra parsedTerm))
  where algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
        decorator = parseDecorator debug
        makeNode :: Record (Maybe SourceText ': DefaultFields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': DefaultFields))) -> ParseNode
@ -85,12 +82,12 @@ parseRoot construct combine args@Arguments{..} = do
          ParseNode (toS category) range head sourceSpan (identifierFor syntax)

 -- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
-parseIndex :: Arguments -> IO ByteString
-parseIndex = fmap (toS . encode) . parseRoot IndexFile (\ node siblings -> node : concat siblings)
+jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString
+jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : concat siblings)

 -- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON.
-parseTree :: Arguments -> IO ByteString
-parseTree = fmap (toS . encode) . parseRoot ParseTreeFile Rose
+jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString
+jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose

 -- | Determines the term decorator to use when parsing.
 parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText))
@ -138,13 +135,6 @@ sourceBlobsFromSha commitSha gitDir filePaths = do
 identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
 identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier

-- | For the file paths and commit sha provided, extract only the BlobEntries and represent them as SourceBlobs.
-sourceBlobsFromArgs :: Arguments -> IO [SourceBlob]
-sourceBlobsFromArgs Arguments{..} =
-  case commitSha of
-    Just commitSha' -> sourceBlobsFromSha commitSha' gitDir filePaths
-    _ -> sourceBlobsFromPaths filePaths
-
 -- | Return a parser incorporating the provided TermDecorator.
 parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record (field ': DefaultFields))
 parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForType (toS (takeExtension path)) blob
--- a/src/Renderer.hs
+++ b/src/Renderer.hs
@ -2,15 +2,15 @@
 module Renderer
 ( DiffRenderer(..)
 , runDiffRenderer
-, Format(..)
 , Summaries(..)
 , File(..)
 ) where

 import Data.Aeson (ToJSON, Value)
 import Data.Functor.Both
+import Data.Functor.Classes
+import Text.Show
 import Data.Map as Map hiding (null)
-import Data.Functor.Listable
 import Data.Record
 import Diff
 import Info
@ -41,21 +41,17 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
  SExpressionDiffRenderer format -> R.sExpression format
  ToCRenderer -> R.toc

-- | The available types of diff rendering.
-data Format = Split | Patch | JSON | Summary | SExpression | TOC | Index | ParseTree
-  deriving (Show)
-
 newtype File = File { unFile :: Text }
  deriving Show

+instance Show (DiffRenderer fields output) where
+  showsPrec _ SplitRenderer = showString "SplitRenderer"
+  showsPrec _ PatchRenderer = showString "PatchRenderer"
+  showsPrec _ JSONDiffRenderer = showString "JSONDiffRenderer"
+  showsPrec _ SummaryRenderer = showString "SummaryRenderer"
+  showsPrec d (SExpressionDiffRenderer format) = showsUnaryWith showsPrec "SExpressionDiffRenderer" d format
+  showsPrec _ ToCRenderer = showString "ToCRenderer"
+
 instance Monoid File where
  mempty = File mempty
  mappend (File a) (File b) = File (a <> "\n" <> b)
-
-instance Listable Format where
-  tiers = cons0 Split
-       \/ cons0 Patch
-       \/ cons0 JSON
-       \/ cons0 Summary
-       \/ cons0 SExpression
-       \/ cons0 TOC
--- a/src/Renderer/SExpression.hs
+++ b/src/Renderer/SExpression.hs
@ -15,6 +15,7 @@ import Syntax
 import Term

 data SExpressionFormat = TreeOnly | TreeAndRanges
+  deriving (Show)

 sExpression :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> Both SourceBlob -> Diff (Syntax Text) (Record fields) -> ByteString
 sExpression format _ diff = printDiff diff 0 format
--- a/src/Semantic.hs
+++ b/src/Semantic.hs
@ -0,0 +1,128 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Semantic (main, runDiff, runParse) where
+
+import Arguments
+import Command
+import Command.Parse
+import Data.Functor.Both
+import Data.List.Split (splitWhen)
+import Data.String
+import Data.Version (showVersion)
+import Development.GitRev
+import Options.Applicative hiding (action)
+import Prologue hiding (concurrently, fst, snd, readFile)
+import qualified Data.ByteString as B
+import qualified Paths_semantic_diff as Library (version)
+import Source
+import System.Directory
+import System.Environment
+import System.FilePath.Posix (takeFileName, (-<.>))
+import System.IO.Error (IOError)
+import Text.Regex
+
+main :: IO ()
+main = do
+  gitDir <- findGitDir
+  alternates <- findAlternates
+  Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates)
+  outputPath <- getOutputPath outputFilePath
+  text <- case programMode of
+    Diff args -> runDiff args
+    Parse args -> runParse args
+  writeToOutput outputPath text
+
+  where
+    findGitDir = do
+      pwd <- getCurrentDirectory
+      fromMaybe pwd <$> lookupEnv "GIT_DIR"
+
+    findAlternates = do
+      eitherObjectDirs <- try $ splitWhen (== ':') . toS <$> getEnv "GIT_ALTERNATE_OBJECT_DIRECTORIES"
+      pure $ case (eitherObjectDirs :: Either IOError [FilePath]) of
+              (Left _) -> []
+              (Right objectDirs) -> objectDirs
+
+    getOutputPath Nothing = pure Nothing
+    getOutputPath (Just path) = do
+      isDir <- doesDirectoryExist path
+      pure . Just $ if isDir then takeFileName path -<.> ".html" else path
+
+    writeToOutput :: Maybe FilePath -> ByteString -> IO ()
+    writeToOutput = maybe B.putStr B.writeFile
+
+runDiff :: DiffArguments -> IO ByteString
+runDiff DiffArguments{..} = runCommand $ do
+  diffs <- case diffMode of
+    DiffPaths pathA pathB -> do
+      let paths = both pathA pathB
+      blobs <- traverse readFile paths
+      terms <- traverse (traverse parseBlob) blobs
+      diff' <- maybeDiff terms
+      pure [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')]
+    DiffCommits sha1 sha2 paths -> do
+      blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2)
+      concurrently blobPairs . uncurry $ \ path blobs -> do
+        terms <- concurrently blobs (traverse parseBlob)
+        diff' <- maybeDiff terms
+        pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
+  encodeDiff (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
+
+runParse :: ParseArguments -> IO ByteString
+runParse ParseArguments{..} = do
+  blobs <- case parseMode of
+    ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
+    ParsePaths paths -> sourceBlobsFromPaths paths
+  renderParseTree debug blobs
+
+-- | A parser for the application's command-line arguments.
+arguments :: FilePath -> [FilePath] -> ParserInfo Arguments
+arguments gitDir alternates = info (version <*> helper <*> argumentsParser) description
+  where
+    version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
+    versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
+    description = fullDesc <> progDesc "Set the GIT_DIR environment variable to specify a different git repository. Set GIT_ALTERNATE_OBJECT_DIRECTORIES to specify location of alternates."
+                           <> header "semantic -- Parse and diff semantically"
+
+    argumentsParser = Arguments
+      <$> hsubparser (diffCommand <> parseCommand)
+      <*> optional (strOption (long "output" <> short 'o' <> help "Output path (directory for split diffs), defaults to stdout"))
+
+    diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
+    diffArgumentsParser = Diff
+      <$> ( DiffArguments
+            <$> (  flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
+               <|> flag' splitDiff (long "split" <> help "Output a split diff")
+               <|> flag' jsonDiff (long "json" <> help "Output a json diff")
+               <|> flag' summaryDiff (long "summary" <> help "Output a diff summary")
+               <|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree")
+               <|> flag' tocDiff (long "toc" <> help "Output a table of contents diff summary") )
+            <*> (  DiffPaths
+                  <$> argument str (metavar "FILE_A")
+                  <*> argument str (metavar "FILE_B")
+               <|> 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 str (metavar "FILES...")) )
+            <*> pure gitDir
+            <*> pure alternates )
+
+    parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths"))
+    parseArgumentsParser = Parse
+      <$> ( ParseArguments
+            <$> (  flag sExpressionParseTree sExpressionParseTree (long "sexpression" <> help "Output s-expression parse trees (default)")
+               <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees")
+               <|> flag' jsonIndexParseTree (long "index" <> help "Output JSON parse trees in index format") )
+            <*> (  ParsePaths
+                  <$> some (argument str (metavar "FILES..."))
+               <|> ParseCommit
+                  <$> option (eitherReader parseSha) (long "sha" <> metavar "SHA" <> help "Commit SHA")
+                  <*> some (argument str (metavar "FILES...")) )
+            <*> switch (long "debug")
+            <*> pure gitDir
+            <*> pure alternates )
+
+    parseSha :: String -> Either String String
+    parseSha s = case matchRegex regex s of
+      Just [sha] -> Right sha
+      _ -> Left $ s <> " is not a valid SHA-1"
+      where regex = mkRegexWithOpts "([0-9a-f]{40})" True False
--- a/src/SemanticDiff.hs
+++ b/src/SemanticDiff.hs
@ -1,94 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module SemanticDiff (main) where
-
-import Arguments
-import Command
-import Command.Parse
-import Development.GitRev
-import Data.Aeson
-import qualified Data.ByteString as B
-import Data.Functor.Both
-import Data.String
-import Data.Version (showVersion)
-import Options.Applicative hiding (action)
-import qualified Paths_semantic_diff as Library (version)
-import Prologue hiding (concurrently, fst, snd, readFile)
-import qualified Renderer as R
-import qualified Renderer.SExpression as R
-import Source
-import Text.Regex
-
-main :: IO ()
-main = do
-  args@Arguments{..} <- programArguments =<< execParser argumentsParser
-  text <- case runMode of
-    Diff -> runCommand $ do
-      let render = case format of
-            R.Split -> fmap encodeText . renderDiffs R.SplitRenderer
-            R.Patch -> fmap encodeText . renderDiffs R.PatchRenderer
-            R.JSON -> fmap encodeJSON . renderDiffs R.JSONDiffRenderer
-            R.Summary -> fmap encodeSummaries . renderDiffs R.SummaryRenderer
-            R.SExpression -> renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
-            R.TOC -> fmap encodeSummaries . renderDiffs R.ToCRenderer
-            _ -> fmap encodeText . renderDiffs R.PatchRenderer
-      diffs <- case diffMode of
-        PathDiff paths -> do
-          blobs <- traverse readFile paths
-          terms <- traverse (traverse parseBlob) blobs
-          diff' <- maybeDiff terms
-          return [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')]
-        CommitDiff -> do
-          blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs filePaths (fromMaybe (toS nullOid) <$> shaRange)
-          concurrently blobPairs . uncurry $ \ path blobs -> do
-            terms <- concurrently blobs (traverse parseBlob)
-            diff' <- maybeDiff terms
-            return (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
-      render (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
-    Parse -> case format of
-      R.Index -> parseIndex args
-      R.SExpression -> parseSExpression args
-      _ -> parseTree args
-  writeToOutput outputPath text
-  where encodeText = encodeUtf8 . R.unFile
-        encodeJSON = toS . (<> "\n") . encode
-        encodeSummaries = toS . (<> "\n") . encode
-
-- | A parser for the application's command-line arguments.
-argumentsParser :: ParserInfo CmdLineOptions
-argumentsParser = info (version <*> helper <*> argumentsP)
-                       (fullDesc <> progDesc "Set the GIT_DIR environment variable to specify the git repository. Set GIT_ALTERNATE_OBJECT_DIRECTORIES to specify location of alternates."
-                                 <> header "semantic-diff - Show semantic changes between commits")
-  where
-    argumentsP :: Parser CmdLineOptions
-    argumentsP = CmdLineOptions
-      <$> (flag R.Split R.Patch (long "patch" <> help "output a patch(1)-compatible diff")
-      <|> flag R.Split R.JSON (long "json" <> help "output a json diff")
-      <|> flag' R.Split (long "split" <> help "output a split diff")
-      <|> flag' R.Summary (long "summary" <> help "output a diff summary")
-      <|> flag' R.SExpression (long "sexpression" <> help "output an s-expression diff tree")
-      <|> flag' R.TOC (long "toc" <> help "output a table of contents diff summary")
-      <|> flag' R.Index (long "index" <> help "output indexable JSON parse output")
-      <|> flag' R.ParseTree (long "parse-tree" <> help "output JSON parse tree structure"))
-      <*> optional (option auto (long "timeout" <> help "timeout for per-file diffs in seconds, defaults to 7 seconds"))
-      <*> optional (strOption (long "output" <> short 'o' <> help "output directory for split diffs, defaults to stdout if unspecified"))
-      <*> optional (strOption (long "commit" <> short 'c' <> help "single commit entry for parsing"))
-      <*> switch (long "no-index" <> help "compare two paths on the filesystem")
-      <*> some (argument (eitherReader parseShasAndFiles) (metavar "SHA_A..SHAB FILES..."))
-      <*> switch (long "debug" <> short 'd' <> help "set debug mode for parsing which outputs sourcetext for each syntax node")
-      <*> flag Diff Parse (long "parse" <> short 'p' <> help "parses a source file without diffing")
-      where
-        parseShasAndFiles :: String -> Either String ExtraArg
-        parseShasAndFiles s = case matchRegex regex s of
-          Just ["", sha2] -> Right . ShaPair $ both Nothing (Just sha2)
-          Just [sha1, sha2] -> Right . ShaPair $ Just <$> both sha1 sha2
-          _ -> Right $ FileArg s
-          where regex = mkRegexWithOpts "([0-9a-f]{40})\\.\\.([0-9a-f]{40})" True False
-
-versionString :: String
-versionString = "semantic-diff version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
-
-version :: Parser (a -> a)
-version = infoOption versionString (long "version" <> short 'V' <> help "output the version of the program")
-
-writeToOutput :: Maybe FilePath -> ByteString -> IO ()
-writeToOutput = maybe B.putStr B.writeFile
--- a/test/Command/Parse/Spec.hs
+++ b/test/Command/Parse/Spec.hs
@ -1,34 +1,20 @@
 module Command.Parse.Spec where

 import Command.Parse
-import Data.Functor.Listable
+import Control.Monad
 import Prelude
 import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
 import Test.Hspec.Expectations.Pretty
-import Test.Hspec.LeanCheck
-import Test.LeanCheck
-import Arguments
-import Renderer

 spec :: Spec
-spec = parallel $
-  context "parse" $
-    prop "all valid formats should produce output" . forAll (isParseFormat `filterT` tiers) $
-      \format ->
-        case format of
-          SExpression -> do
-            output <- parseSExpression $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
-          Index -> do
-            output <- parseIndex $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
-          _ -> do
-            output <- parseTree $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
-
-isParseFormat :: Format -> Bool
-isParseFormat a | Index <- a = True
-                | ParseTree <- a = True
-                | JSON <- a = True
-                | SExpression <- a = True
-                | otherwise = False
+spec = parallel . context "parse" $ do
+    let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
+    it "should produce s-expression trees" $ do
+      output <- sExpressionParseTree False =<< blobs
+      output `shouldNotBe` ""
+    it "should produce JSON trees" $ do
+      output <- jsonParseTree False =<< blobs
+      output `shouldNotBe` ""
+    it "should produce JSON index" $ do
+      output <- jsonIndexParseTree False =<< blobs
+      output `shouldNotBe` ""
--- a/test/SemanticSpec.hs
+++ b/test/SemanticSpec.hs
@ -0,0 +1,23 @@
+module SemanticSpec where
+
+import Prologue
+import Arguments
+import Semantic
+import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
+import Test.Hspec.Expectations.Pretty
+import Test.Hspec.LeanCheck
+
+spec :: Spec
+spec = parallel $ do
+  describe "runDiff" $ do
+    prop "produces diffs for all formats" $
+      \ encoder -> do
+          let mode = DiffPaths "test/fixtures/ruby/and-or.A.rb" "test/fixtures/ruby/and-or.B.rb"
+          output <- runDiff $ DiffArguments encoder mode "" []
+          output `shouldNotBe` ""
+  describe "runParse" $ do
+    prop "produces parse trees for all formats" $
+      \ renderer -> do
+          let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
+          output <- runParse $ ParseArguments renderer mode False "" []
+          output `shouldNotBe` ""
--- a/test/Spec.hs
+++ b/test/Spec.hs
@ -19,6 +19,7 @@ import qualified SourceSpec
 import qualified TermSpec
 import qualified TOCSpec
 import qualified IntegrationSpec
+import qualified SemanticSpec
 import Test.Hspec

 main :: IO ()
@ -39,6 +40,7 @@ main = hspec $ do
    describe "SES.Myers" SES.Myers.Spec.spec
    describe "Source" SourceSpec.spec
    describe "Term" TermSpec.spec
+    describe "Semantic" SemanticSpec.spec
    describe "TOC" TOCSpec.spec
    describe "Integration" IntegrationSpec.spec