Transition sexpression term rendering

semantic.cabal

@@ -190,6 +190,7 @@ library
                      , Semantic.API.Diff
                      , Semantic.API.Converters
                      , Semantic.API.Parse
+                     , Semantic.API.SExpressions
                      , Semantic.API.Symbols
                      , Semantic.API.TOCSummaries
                      , Semantic.API.Types

src/Rendering/Renderer.hs

@@ -49,8 +49,6 @@ data TermRenderer output where
   JSONTermRenderer :: TermRenderer (JSON "trees" SomeJSON)
   -- | Render to JSON as an adjacency list represenation.
   JSONGraphTermRenderer :: TermRenderer (JSON "trees" SomeJSON)
-  -- | Render to a 'ByteString' formatted as nested s-expressions.
-  SExpressionTermRenderer :: TermRenderer Builder
   -- | Render to a 'ByteString' formatted as a DOT description of the term.
   DOTTermRenderer :: TermRenderer (Graph TermVertex)
   -- | Render to a 'ByteString' formatted using the 'Show' instance.

src/Semantic/API.hs

@@ -1,10 +1,12 @@
 module Semantic.API
   (
-    module SymbolsAPI
+    module SExpressionsAPI
+  , module SymbolsAPI
   , module TOCSummariesAPI
   , module Types
   ) where
 
+import Semantic.API.SExpressions as SExpressionsAPI
 import Semantic.API.Symbols as SymbolsAPI
 import Semantic.API.TOCSummaries as TOCSummariesAPI
 import Semantic.API.Types as Types

src/Semantic/API/SExpressions.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
+module Semantic.API.SExpressions (parseSExpressionBuilder) where
+
+import Control.Effect
+import Control.Exception
+import Data.Blob
+import Data.ByteString.Builder
+import Parsing.Parser
+import Semantic.API.Parse
+import Semantic.Task as Task
+import Serializing.Format
+
+parseSExpressionBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m)
+  => t Blob -> m Builder
+parseSExpressionBuilder = distributeFoldMap go
+  where
+    go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m Builder
+    go blob@Blob{..} = doParse blobLanguage blob (\_ (SomeTerm t) -> runSerialize Plain (SExpression ByConstructorName) t)

src/Semantic/API/Symbols.hs

@@ -9,7 +9,7 @@ import           Data.ByteString.Builder
 import Data.Location
 import Data.Maybe
 import Data.Term
-import qualified Data.Text as T
+import Data.Text (pack)
 import Parsing.Parser
 import Semantic.API.Converters
 import Semantic.API.Parse
@@ -28,7 +28,7 @@ parseSymbols blobs = ParseTreeSymbolResponse <$> distributeFoldMap go blobs
   where
     go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m [File]
     go blob@Blob{..} = doParse blobLanguage blob render `catchError` (\(SomeException _) -> pure (pure emptyFile))
-      where emptyFile = File (T.pack blobPath) (T.pack (show blobLanguage)) []
+      where emptyFile = File (pack blobPath) (pack (show blobLanguage)) []
 
     render :: Blob -> SomeTerm TermConstraints Location -> [File]
     render blob (SomeTerm term) = renderToSymbols blob term
@@ -37,7 +37,7 @@ parseSymbols blobs = ParseTreeSymbolResponse <$> distributeFoldMap go blobs
     renderToSymbols blob term = either mempty (pure . tagsToFile blob) (runTagging blob term)
 
     tagsToFile :: Blob -> [Tag] -> File
-    tagsToFile Blob{..} tags = File (T.pack blobPath) (T.pack (show blobLanguage)) (fmap tagToSymbol tags)
+    tagsToFile Blob{..} tags = File (pack blobPath) (pack (show blobLanguage)) (fmap tagToSymbol tags)
 
     tagToSymbol :: Tag -> Symbol
     tagToSymbol Tag{..}

src/Semantic/CLI.hs

@@ -16,7 +16,7 @@ import           Data.Project
 import           Options.Applicative hiding (style)
 import           Prologue
 import           Rendering.Renderer
-import           Semantic.API (parseSymbolsBuilder, diffSummaryBuilder)
+import           Semantic.API (parseSymbolsBuilder, parseSExpressionBuilder, diffSummaryBuilder)
 import qualified Semantic.AST as AST
 import           Semantic.Config
 import qualified Semantic.Diff as Diff
@@ -80,7 +80,7 @@ parseCommand :: Mod CommandFields (Task.TaskEff Builder)
 parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
   where
     parseArgumentsParser = do
-      renderer <- flag  (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
+      renderer <- flag  parseSExpressionBuilder                  parseSExpressionBuilder                  (long "sexpression" <> help "Output s-expression parse trees (default)")
               <|> flag'                                          (Parse.runParse JSONTermRenderer)        (long "json"        <> help "Output JSON parse trees")
               <|> flag'                                          (Parse.runParse JSONGraphTermRenderer)   (long "json-graph"  <> help "Output JSON adjacency list")
               <|> flag'                                          (parseSymbolsBuilder JSON)               (long "symbols"     <> help "Output JSON symbol list")

src/Semantic/Parse.hs

@@ -31,7 +31,6 @@ runParse JSONTermRenderer             = withParsedBlobs' renderJSONError (render
 runParse JSONGraphTermRenderer        = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON
   where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON
         renderAdjGraph blob term = renderJSONAdjTerm blob (renderTreeGraph term)
-runParse SExpressionTermRenderer      = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
 runParse ShowTermRenderer             = withParsedBlobs (const (serialize Show . quieterm))
 runParse DOTTermRenderer              = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
 runParse QuietTermRenderer            = distributeFoldMap $ \blob ->

test/Semantic/CLI/Spec.hs

@@ -4,7 +4,7 @@ import           Control.Monad (when)
 import qualified Data.ByteString as B
 import           Data.ByteString.Builder
 import           Data.Foldable (for_)
-import           Semantic.API (parseSymbolsBuilder, diffSummaryBuilder)
+import           Semantic.API (parseSymbolsBuilder, parseSExpressionBuilder, diffSummaryBuilder)
 import           Semantic.CLI
 import           Semantic.IO
 import           Semantic.Task
@@ -34,7 +34,7 @@ spec = parallel $ do
 
 parseFixtures :: [(String, [Blob] -> TaskEff Builder, [File], FilePath)]
 parseFixtures =
-  [ (show SExpressionTermRenderer, runParse SExpressionTermRenderer, path, "test/fixtures/ruby/corpus/and-or.parseA.txt")
+  [ ("s-expression", parseSExpressionBuilder, path, "test/fixtures/ruby/corpus/and-or.parseA.txt")
   , (show JSONTermRenderer, runParse JSONTermRenderer, path, prefix </> "parse-tree.json")
   , (show JSONTermRenderer, runParse JSONTermRenderer, path', prefix </> "parse-trees.json")
   , (show JSONTermRenderer, runParse JSONTermRenderer, [], prefix </> "parse-tree-empty.json")

test/Semantic/Spec.hs

@@ -3,6 +3,7 @@ module Semantic.Spec (spec) where
 import Data.Diff
 import Data.Patch
 import Semantic.Parse
+import Semantic.API
 import System.Exit
 
 import SpecHelpers
@@ -16,10 +17,10 @@ spec = parallel $ do
       output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n"
 
     it "throws if given an unknown language for sexpression output" $ do
-      runTask (runParse SExpressionTermRenderer [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1)
+      runTask (parseSExpressionBuilder [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1)
 
     it "renders with the specified renderer" $ do
-      output <- fmap runBuilder . runTask $ runParse SExpressionTermRenderer [methodsBlob]
+      output <- fmap runBuilder . runTask $ parseSExpressionBuilder [methodsBlob]
       output `shouldBe` "(Statements\n  (Method\n    (Empty)\n    (Identifier)\n    (Statements)))\n"
   where
     methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby

test/SpecHelpers.hs

@@ -83,6 +83,7 @@ import Data.Set (Set)
 import qualified Semantic.IO as IO
 import Semantic.Config (Config)
 import Semantic.Telemetry (LogQueue, StatQueue)
+import Semantic.API (parseSExpressionBuilder)
 import System.Exit (die)
 import Control.Exception (displayException)
 
@@ -99,7 +100,7 @@ diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>=
 
 -- | Returns an s-expression parse tree for the specified FilePath.
 parseFilePath :: TaskConfig -> FilePath -> IO ByteString
-parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder)
+parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . parseSExpressionBuilder @[] . pure >>= either (die . displayException) (pure . runBuilder)
 
 -- | Read two files to a BlobPair.
 readFilePair :: Both FilePath -> IO BlobPair