Factor the ts-parse command into its own module.

semantic.cabal

@@ -139,6 +139,7 @@ library
                      , Rendering.Symbol
                      , Rendering.TOC
                      -- High-level flow & operational functionality (logging, stats, etc.)
+                     , Semantic.AST
                      , Semantic.CLI
                      , Semantic.Diff
                      , Semantic.Distribute

src/Semantic/AST.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE GADTs, RankNTypes #-}
+module Semantic.AST where
+
+import Data.AST
+import Data.Blob
+import Data.Output
+import Parsing.Parser
+import Prologue hiding (MonadError(..))
+import Rendering.Renderer
+import Semantic.IO (noLanguageForBlob)
+import Semantic.Task
+import qualified Serializing.Format as F
+
+data SomeAST where
+  SomeAST :: Show grammar => AST [] grammar -> SomeAST
+
+withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
+withSomeAST f (SomeAST ast) = f ast
+
+astParseBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs SomeAST
+astParseBlob blob@Blob{..}
+  | Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
+  = SomeAST <$> parse parser blob
+  | otherwise = noLanguageForBlob blobPath
+
+
+data ASTFormat = SExpression | JSON
+  deriving (Show)
+
+runASTParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effects => ASTFormat -> [Blob] -> Eff effects F.Builder
+runASTParse SExpression = distributeFoldMap (WrapTask . (withSomeAST (serialize (F.SExpression F.ByShow)) <=< astParseBlob))
+runASTParse JSON        = fmap toOutput . distributeFoldMap (\ blob -> WrapTask (withSomeAST (render (renderJSONAST blob)) =<< astParseBlob blob))

src/Semantic/CLI.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ApplicativeDo, TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-}
 module Semantic.CLI
 ( main
 -- Testing
@@ -18,11 +18,12 @@ import           Options.Applicative hiding (style)
 import qualified Paths_semantic as Library (version)
 import           Prologue
 import           Rendering.Renderer
+import qualified Semantic.AST as AST
 import qualified Semantic.Diff as Semantic (diffBlobPairs)
 import           Semantic.Graph as Semantic (Graph, GraphType(..), Vertex, graph, style)
 import           Semantic.IO as IO
 import qualified Semantic.Log as Log
-import qualified Semantic.Parse as Semantic (parseBlobs, astParseBlobs)
+import qualified Semantic.Parse as Semantic (parseBlobs)
 import qualified Semantic.Task as Task
 import           Serializing.Format
 import           Text.Read
@@ -36,8 +37,11 @@ runDiff (SomeRenderer diffRenderer) = fmap toOutput . Semantic.diffBlobPairs dif
 runParse :: SomeRenderer TermRenderer -> Either (Handle 'IO.ReadMode) [File] -> Task.TaskEff Builder
 runParse (SomeRenderer parseTreeRenderer) = fmap toOutput . Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
-runASTParse :: SomeRenderer TermRenderer -> Either (Handle 'IO.ReadMode) [File] -> Task.TaskEff Builder
-runASTParse (SomeRenderer parseTreeRenderer) = fmap toOutput . Semantic.astParseBlobs parseTreeRenderer <=< Task.readBlobs
+
+
+-- runASTParse :: Monoid output => (forall grammar . Show grammar => AST [] grammar -> TaskEff output) -> Either (Handle 'IO.ReadMode) [File] -> Task.TaskEff Builder
+-- runASTParse = distribute (WrapTask . astParseBlob)
+-- runASTParse parseTreeRenderer = fmap toOutput . Semantic.astParseBlobs parseTreeRenderer <=< Task.readBlobs
 
 runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex)
 runGraph graphType rootDir dir excludeDirs = Semantic.graph graphType <=< Task.readProject rootDir dir excludeDirs
@@ -91,10 +95,10 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
 
     tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
     tsParseArgumentsParser = do
-      renderer <- flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression ASTs (default)")
-              <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json"        <> help "Output JSON ASTs")
+      format <- flag  AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)")
+            <|> flag'                 AST.JSON        (long "json"        <> help "Output JSON ASTs")
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
-      pure $ runASTParse renderer filesOrStdin
+      pure $ AST.runASTParse format =<< Task.readBlobs filesOrStdin
 
     graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point"))
     graphArgumentsParser = do

src/Semantic/IO.hs

@@ -12,7 +12,6 @@ module Semantic.IO
 , languageForFilePath
 , NoLanguageForBlob(..)
 , noLanguageForBlob
-, FormatNotSupported(..)
 , readBlob
 , readProject
 , readBlobs
@@ -193,10 +192,6 @@ noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
 noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
 
 
--- | An exception indicating that the output format is not supported
-newtype FormatNotSupported = FormatNotSupported String
-  deriving (Eq, Exception, Ord, Show, Typeable)
-
 readBlob :: Member Files effs => File -> Eff effs Blob.Blob
 readBlob = send . Read . FromPath
 

src/Semantic/Parse.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, RankNTypes #-}
 module Semantic.Parse where
 
 import Analysis.ConstructorName (ConstructorName, constructorLabel)
@@ -13,7 +13,7 @@ import Parsing.Parser
 import Prologue hiding (MonadError(..))
 import Rendering.Graph
 import Rendering.Renderer
-import Semantic.IO (noLanguageForBlob, FormatNotSupported(..))
+import Semantic.IO (noLanguageForBlob)
 import Semantic.Task
 import Serializing.Format
 
@@ -36,16 +36,3 @@ renderSomeTerm renderer blob@Blob{..} = withSomeTerm $ case renderer of
 -- | A task to parse a 'Blob' and render the resulting 'Term'.
 parseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
 parseBlob renderer blob@Blob{..} = parseSomeBlob blob >>= renderSomeTerm renderer blob
-
-
-astParseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => TermRenderer output -> [Blob] -> Eff effs output
-astParseBlobs renderer = distributeFoldMap (WrapTask . astParseBlob renderer)
-  where
-    astParseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
-    astParseBlob renderer blob@Blob{..}
-      | Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
-      = parse parser blob >>= case renderer of
-        SExpressionTermRenderer    -> serialize (SExpression ByShow) . fmap nodeSymbol
-        JSONTermRenderer           -> render (renderJSONAST blob)
-        _                          -> pure $ throwError (SomeException (FormatNotSupported "Only SExpression and JSON output supported for tree-sitter ASTs."))
-      | otherwise = noLanguageForBlob blobPath