WIP - parse tree renderer

src/Arguments.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs, DuplicateRecordFields #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 module Arguments where
 
 import Command
 import Data.Maybe
 import Prelude
+import Renderer
 
 
 data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath
@@ -21,7 +22,7 @@ data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath]
   deriving Show
 
 data ParseArguments = ParseArguments
-  { renderParseTree :: ParseTreeRenderer
+  { parseTreeFormat :: DefaultParseTreeRenderer
   , parseMode :: ParseMode
   , debug :: Bool
   , gitDir :: FilePath

src/Command.hs

@@ -18,13 +18,12 @@ module Command
 , sExpressionDiff
 , tocDiff
 , DiffEncoder
-, ParseTreeRenderer
+-- , ParseTreeEncoder
 -- Evaluation
 , runCommand
 ) where
 
 import Command.Files
-import Command.Parse
 import qualified Control.Concurrent.Async.Pool as Async
 import Control.Exception (catch)
 import Control.Monad.Free.Freer
@@ -205,7 +204,7 @@ runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBl
 runRenderDiffs = runDiffRenderer
 
 
-type ParseTreeRenderer = Bool -> [SourceBlob] -> IO ByteString
+-- type ParseTreeEncoder = Bool -> [Term (Syntax Text) (Record DefaultFields)] -> Command ByteString
 
 type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
 
@@ -236,14 +235,14 @@ 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 ParseTreeEncoder where
+--   showsPrec d _ = showParen (d >= 10) $ showString "ParseTreeEncoder "
+-- --
+-- instance Listable ParseTreeEncoder where
+--   tiers = cons0 jsonParseTree
+--        \/ cons0 jsonIndexParseTree
+--        \/ cons0 sExpressionParseTree
 
 instance Show DiffEncoder where
   showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "

src/Renderer.hs

@@ -2,6 +2,9 @@
 module Renderer
 ( DiffRenderer(..)
 , runDiffRenderer
+, DefaultParseTreeRenderer
+, ParseTreeRenderer(..)
+, runParseTreeRenderer
 , Summaries(..)
 , File(..)
 ) where
@@ -23,6 +26,8 @@ import Renderer.Summary as R
 import Renderer.TOC as R
 import Source (SourceBlob)
 import Syntax
+import Term
+import Data.Functor.Listable
 
 data DiffRenderer fields output where
   SplitRenderer :: (HasField fields Category, HasField fields Range) => DiffRenderer fields File
@@ -41,6 +46,18 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
   SExpressionDiffRenderer format -> R.sExpression format
   ToCRenderer -> R.toc
 
+
+type DefaultParseTreeRenderer = ParseTreeRenderer DefaultFields ByteString
+
+data ParseTreeRenderer fields output where
+  SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString
+
+runParseTreeRenderer :: Monoid output => ParseTreeRenderer fields output -> [Term (Syntax Text) (Record fields)] -> output
+runParseTreeRenderer renderer = foldMap $ case renderer of
+  SExpressionParseTreeRenderer format -> printTerm format
+  where
+    printTerm format term = R.printTerm term 0 format
+
 newtype File = File { unFile :: Text }
   deriving Show
 
@@ -52,6 +69,12 @@ instance Show (DiffRenderer fields output) where
   showsPrec d (SExpressionDiffRenderer format) = showsUnaryWith showsPrec "SExpressionDiffRenderer" d format
   showsPrec _ ToCRenderer = showString "ToCRenderer"
 
+instance Show (ParseTreeRenderer fields output) where
+  showsPrec d (SExpressionParseTreeRenderer format) = showsUnaryWith showsPrec "SExpressionParseTreeRenderer" d format
+
 instance Monoid File where
   mempty = File mempty
   mappend (File a) (File b) = File (a <> "\n" <> b)
+
+instance Listable DefaultParseTreeRenderer where
+  tiers = cons0 (SExpressionParseTreeRenderer TreeOnly)

src/Semantic.hs

@@ -12,6 +12,7 @@ import Prologue
 import Renderer
 import Source
 import Syntax
+import Control.Parallel.Strategies
 import Term
 
 
@@ -25,17 +26,17 @@ import Term
 diffBlobs :: (Monoid output, StringConv output ByteString) => DiffRenderer DefaultFields output -> [Both SourceBlob] -> IO ByteString
 diffBlobs renderer blobs = do
   diffs <- traverse go blobs
-  pure . toS $ runDiffRenderer renderer diffs
+  pure . toS $ runDiffRenderer renderer (diffs `using` parTraversable (parTuple2 r0 rdeepseq))
   where
     go blobPair = do
       diff <- diffBlobs' blobPair
       pure (blobPair, diff)
 
--- | Diff a pair of blobs
+-- | Diff a pair of blobs.
 diffBlobs' :: Both SourceBlob -> IO (Diff (Syntax Text) (Record DefaultFields))
 diffBlobs' blobs = do
   terms <- traverse parseBlob' blobs
-  pure $ stripDiff (runBothWith diffTerms (fmap decorate terms))
+  pure $ stripDiff (runBothWith diffTerms (fmap decorate (terms `using` parTraversable rdeepseq)))
   where
     decorate = defaultFeatureVectorDecorator getLabel
     getLabel :: HasField fields Category => TermF (Syntax Text) (Record fields) a -> (Category, Maybe Text)
@@ -43,8 +44,11 @@ diffBlobs' blobs = do
       Leaf s -> Just s
       _ -> Nothing)
 
--- TODO
--- parseBlob :: SourceBlob -> IO ByteString
+-- | Parse a list of blobs and use the specified renderer to produce ByteString output.
+parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString
+parseBlobs renderer blobs = do
+  terms <- traverse parseBlob' blobs
+  pure . toS $ runParseTreeRenderer renderer (terms `using` parTraversable rdeepseq)
 
 -- | Parse a SourceBlob.
 parseBlob' :: SourceBlob -> IO (Term (Syntax Text) (Record DefaultFields))

src/SemanticCmdLine.hs

@@ -16,11 +16,14 @@ import Prologue hiding (concurrently, fst, snd, readFile)
 import qualified Data.ByteString as B
 import qualified Paths_semantic_diff as Library (version)
 import Source
+import Renderer
+import Renderer.SExpression
 import System.Directory
 import System.Environment
 import System.FilePath.Posix (takeFileName, (-<.>))
 import System.IO.Error (IOError)
 import Text.Regex
+import qualified Semantic (parseBlobs)
 
 main :: IO ()
 main = do
@@ -74,7 +77,9 @@ runParse ParseArguments{..} = do
   blobs <- case parseMode of
     ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
     ParsePaths paths -> sourceBlobsFromPaths paths
-  renderParseTree debug blobs
+  Semantic.parseBlobs parseTreeFormat blobs
+  -- toS $ runParseTreeRenderer renderParseTree blobs
+  -- renderParseTree debug blobs
 
 -- | A parser for the application's command-line arguments.
 arguments :: FilePath -> [FilePath] -> ParserInfo Arguments
@@ -111,9 +116,9 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
     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") )
+            <$> (  flag (SExpressionParseTreeRenderer TreeOnly) (SExpressionParseTreeRenderer TreeOnly) (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