Command.Parse doesn't need to know about Arguments

src/Arguments.hs

@@ -47,12 +47,3 @@ args gitDir sha1 sha2 paths format = Arguments
       }
   , outputFilePath = Nothing
   }
-
-parseArgs :: [String] -> R.ParseFormat -> ParseArguments
-parseArgs paths format = ParseArguments
-  { parseFormat = format
-  , parseMode = ParsePaths paths
-  , debug = False
-  , gitDir = ""
-  , alternateObjectDirs = []
-  }

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 :: ParseArguments -> IO ByteString
-parseSExpression =
-  pure . printTerms TreeOnly <=< parse <=< sourceBlobsFromArgs
+parseSExpression :: [SourceBlob] -> IO ByteString
+parseSExpression 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) -> ParseArguments -> IO [root]
-parseRoot construct combine args@ParseArguments{..} = 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@ParseArguments{..} = do
           ParseNode (toS category) range head sourceSpan (identifierFor syntax)
 
 -- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
-parseIndex :: ParseArguments -> IO ByteString
-parseIndex = fmap (toS . encode) . parseRoot IndexFile (\ node siblings -> node : concat siblings)
+parseIndex :: Bool -> [SourceBlob] -> IO ByteString
+parseIndex 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 :: ParseArguments -> IO ByteString
-parseTree = fmap (toS . encode) . parseRoot ParseTreeFile Rose
+parseTree :: Bool -> [SourceBlob] -> IO ByteString
+parseTree 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 :: ParseArguments -> IO [SourceBlob]
-sourceBlobsFromArgs ParseArguments{..} =
-  case parseMode of
-    ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
-    ParsePaths paths -> sourceBlobsFromPaths paths
-
 -- | 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

src/SemanticDiff.hs

@@ -29,6 +29,7 @@ main = do
   alternates <- findAlternates
   Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates)
   text <- case programMode of
+
     Diff DiffArguments{..} -> runCommand $ do
       let render = case diffFormat of
             R.Split -> fmap encodeText . renderDiffs R.SplitRenderer
@@ -51,10 +52,17 @@ main = do
             diff' <- maybeDiff terms
             pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
       render (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
-    Parse args'@ParseArguments{..} -> case parseFormat of
-      R.JSONTree -> parseTree args'
-      R.JSONIndex -> parseIndex args'
-      R.SExpressionTree -> parseSExpression args'
+
+    Parse ParseArguments{..} -> do
+      let renderTree = case parseFormat of
+            R.JSONTree -> parseTree debug
+            R.JSONIndex -> parseIndex debug
+            R.SExpressionTree -> parseSExpression
+      blobs <- case parseMode of
+        ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
+        ParsePaths paths -> sourceBlobsFromPaths paths
+      renderTree blobs
+
   outputPath <- getOutputPath outputFilePath
   writeToOutput outputPath text
 

test/Command/Parse/Spec.hs

@@ -1,25 +1,20 @@
 module Command.Parse.Spec where
 
 import Command.Parse
+import Control.Monad
 import Prelude
 import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
 import Test.Hspec.Expectations.Pretty
-import Test.Hspec.LeanCheck
-import Arguments
-import Renderer
 
 spec :: Spec
-spec = parallel $ do
-  context "parse" $ do
-    prop "all valid formats should produce output" $
-      \format ->
-        case format of
-          SExpressionTree -> do
-            output <- parseSExpression $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
-          JSONIndex -> do
-            output <- parseIndex $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
-          JSONTree -> do
-            output <- parseTree $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format
-            output `shouldNotBe` ""
+spec = parallel . context "parse" $ do
+    let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
+    it "should produce s-expression trees" $ do
+      output <- parseSExpression =<< blobs
+      output `shouldNotBe` ""
+    it "should produce JSON trees" $ do
+      output <- parseTree False =<< blobs
+      output `shouldNotBe` ""
+    it "should produce JSON index" $ do
+      output <- parseIndex False =<< blobs
+      output `shouldNotBe` ""