diff --git a/src/Arguments.hs b/src/Arguments.hs index 26d35cc2e..3eb3f905e 100644 --- a/src/Arguments.hs +++ b/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 diff --git a/src/Command.hs b/src/Command.hs index 368d73910..d7b84fa8e 100644 --- a/src/Command.hs +++ b/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 " diff --git a/src/Renderer.hs b/src/Renderer.hs index b95fdebb4..1dab458ab 100644 --- a/src/Renderer.hs +++ b/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) diff --git a/src/Semantic.hs b/src/Semantic.hs index 2b50612d4..cde3fb4f5 100644 --- a/src/Semantic.hs +++ b/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)) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index f22f2f04d..e3401f17c 100644 --- a/src/SemanticCmdLine.hs +++ b/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