mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
No more TermRenderer and all tests passing
This commit is contained in:
Timothy Clem
parent
9f222adcd3
commit
dad86f11e7
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, StandaloneDeriving, TypeOperators #-}
|
||||
module Rendering.Renderer
|
||||
( DiffRenderer(..)
|
||||
, TermRenderer(..)
|
||||
, renderJSONDiff
|
||||
, renderJSONAdjDiff
|
||||
, renderJSONTerm
|
||||
@ -42,15 +41,3 @@ data DiffRenderer output where
|
||||
|
||||
deriving instance Eq (DiffRenderer output)
|
||||
deriving instance Show (DiffRenderer output)
|
||||
|
||||
-- | Specification of renderers for terms, producing output in the parameter type.
|
||||
data TermRenderer output where
|
||||
-- | Render to JSON with the format documented in docs/json-format.md under “Term.”
|
||||
JSONTermRenderer :: TermRenderer (JSON "trees" SomeJSON)
|
||||
-- | Render to JSON as an adjacency list represenation.
|
||||
JSONGraphTermRenderer :: TermRenderer (JSON "trees" SomeJSON)
|
||||
-- | Render to a 'ByteString' formatted as a DOT description of the term.
|
||||
DOTTermRenderer :: TermRenderer (Graph TermVertex)
|
||||
|
||||
deriving instance Eq (TermRenderer output)
|
||||
deriving instance Show (TermRenderer output)
|
||||
|
||||
@ -4,7 +4,10 @@ module Semantic.API.Terms
|
||||
, TermOutputFormat(..)
|
||||
) where
|
||||
|
||||
|
||||
-- import Data.Aeson (ToJSON)
|
||||
import Control.Effect
|
||||
import Control.Monad
|
||||
import Control.Effect.Error
|
||||
-- import Control.Exception
|
||||
import Data.Blob
|
||||
@ -15,28 +18,67 @@ import Semantic.Task as Task
|
||||
import Control.Monad.IO.Class
|
||||
import Serializing.Format
|
||||
import Data.Either
|
||||
import Rendering.Graph
|
||||
import Rendering.JSON hiding (JSON)
|
||||
import qualified Rendering.JSON
|
||||
|
||||
data TermOutputFormat
|
||||
= TermJSON
|
||||
= TermJSONTree
|
||||
| TermJSONGraph
|
||||
| TermSExpression
|
||||
| TermDotGraph
|
||||
| TermShow
|
||||
| TermQuiet
|
||||
deriving (Eq, Show)
|
||||
|
||||
parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, MonadIO m)
|
||||
=> TermOutputFormat-> t Blob -> m Builder
|
||||
parseTermBuilder format = distributeFoldMap (go format)
|
||||
parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize JSON
|
||||
parseTermBuilder TermJSONGraph = distributeFoldMap jsonGraph >=> serialize JSON
|
||||
parseTermBuilder TermSExpression = distributeFoldMap sexpTerm
|
||||
parseTermBuilder TermDotGraph = distributeFoldMap dotGraphTerm
|
||||
parseTermBuilder TermShow = distributeFoldMap showTerm
|
||||
parseTermBuilder TermQuiet = distributeFoldMap quietTerm
|
||||
|
||||
jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonTerm blob = (doParse blob >>= withSomeTerm (pure . renderJSONTerm blob)) `catchError` jsonError blob
|
||||
|
||||
jsonGraph :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonGraph blob = (doParse blob >>= withSomeTerm (pure . renderJSONAdjTerm blob)) `catchError` jsonError blob
|
||||
|
||||
jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonError blob (SomeException e) = pure $ renderJSONError blob (show e)
|
||||
|
||||
sexpTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
sexpTerm = doParse >=> withSomeTerm (serialize (SExpression ByConstructorName))
|
||||
|
||||
dotGraphTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
dotGraphTerm = doParse >=> withSomeTerm (serialize (DOT (termStyle "terms")) . renderTreeGraph)
|
||||
|
||||
showTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
showTerm = doParse >=> withSomeTerm (serialize Show . quieterm)
|
||||
|
||||
quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder
|
||||
quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm)) `catchError` timingError )
|
||||
where
|
||||
go :: (ParseEffects sig m, MonadIO m)
|
||||
=> TermOutputFormat -> Blob -> m Builder
|
||||
go TermJSON blob@Blob{..} = doParse blob >>= withSomeTerm (serialize JSON)
|
||||
go TermSExpression blob@Blob{..} = doParse blob >>= withSomeTerm (serialize (SExpression ByConstructorName))
|
||||
go TermShow blob = doParse blob >>= withSomeTerm (serialize Show . quieterm)
|
||||
go TermQuiet blob = showTiming blob <$> time'
|
||||
(
|
||||
(doParse blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm))
|
||||
`catchError` \(SomeException e) -> pure (Left (show e))
|
||||
)
|
||||
where showTiming Blob{..} (res, duration) =
|
||||
let status = if isLeft res then "ERR" else "OK"
|
||||
in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
|
||||
timingError (SomeException e) = pure (Left (show e))
|
||||
showTiming Blob{..} (res, duration) =
|
||||
let status = if isLeft res then "ERR" else "OK"
|
||||
in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
|
||||
|
||||
-- parseTermBuilder format = distributeFoldMap (go format)
|
||||
-- where
|
||||
-- go :: (ParseEffects sig m, MonadIO m) => TermOutputFormat -> Blob -> m Builder
|
||||
-- go TermJSONTree blob = (doParse blob >>= withSomeTerm (serialize JSON . renderJSONTerm blob)) `catchError` jsonError blob
|
||||
-- go TermJSONGraph blob = (doParse blob >>= withSomeTerm (serialize JSON . renderJSONAdjTerm blob . renderTreeGraph)) `catchError` jsonError blob
|
||||
-- go TermSExpression blob = doParse blob >>= withSomeTerm (serialize (SExpression ByConstructorName))
|
||||
-- go TermDotGraph blob = doParse blob >>= withSomeTerm (serialize (DOT (termStyle "terms")) . renderTreeGraph)
|
||||
-- go TermShow blob = doParse blob >>= withSomeTerm (serialize Show . quieterm)
|
||||
-- go TermQuiet blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm)) `catchError` timingError )
|
||||
--
|
||||
-- jsonError blob (SomeException e) = serialize JSON (renderJSONError blob (show e))
|
||||
-- timingError (SomeException e) = pure (Left (show e))
|
||||
--
|
||||
-- showTiming Blob{..} (res, duration) =
|
||||
-- let status = if isLeft res then "ERR" else "OK"
|
||||
-- in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n")
|
||||
|
||||
@ -3,7 +3,6 @@ module Semantic.CLI
|
||||
( main
|
||||
-- Testing
|
||||
, Diff.runDiff
|
||||
, Parse.runParse
|
||||
) where
|
||||
|
||||
import Control.Exception as Exc (displayException)
|
||||
@ -80,13 +79,13 @@ parseCommand :: Mod CommandFields (Task.TaskEff Builder)
|
||||
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
|
||||
where
|
||||
parseArgumentsParser = do
|
||||
renderer <- flag (parseTermBuilder TermJSON) (parseTermBuilder TermJSON) (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 (long "symbols" <> help "Output JSON symbol list")
|
||||
<|> flag' (Parse.runParse DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees")
|
||||
<|> flag' (parseTermBuilder TermShow) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
|
||||
<|> flag' (parseTermBuilder TermQuiet) (long "quiet" <> help "Don't produce output, but show timing stats")
|
||||
renderer <- flag (parseTermBuilder TermSExpression) (parseTermBuilder TermSExpression) (long "sexpression" <> help "Output s-expression parse trees (default)")
|
||||
<|> flag' (parseTermBuilder TermJSONTree) (long "json" <> help "Output JSON parse trees")
|
||||
<|> flag' (parseTermBuilder TermJSONGraph) (long "json-graph" <> help "Output JSON adjacency list")
|
||||
<|> flag' parseSymbolsBuilder (long "symbols" <> help "Output JSON symbol list")
|
||||
<|> flag' (parseTermBuilder TermDotGraph) (long "dot" <> help "Output DOT graph parse trees")
|
||||
<|> flag' (parseTermBuilder TermShow) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
|
||||
<|> flag' (parseTermBuilder TermQuiet) (long "quiet" <> help "Don't produce output, but show timing stats")
|
||||
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||
pure $ Task.readBlobs filesOrStdin >>= renderer
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes #-}
|
||||
module Semantic.Parse ( runParse, runParse', parseSomeBlob ) where
|
||||
module Semantic.Parse (runParse', parseSomeBlob ) where
|
||||
|
||||
import Analysis.ConstructorName (ConstructorName)
|
||||
import Analysis.PackageDef (HasPackageDef)
|
||||
@ -25,14 +25,6 @@ import Semantic.Task
|
||||
import Serializing.Format
|
||||
import Tags.Taggable
|
||||
|
||||
-- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output.
|
||||
runParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => TermRenderer output -> [Blob] -> m Builder
|
||||
runParse JSONTermRenderer = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON
|
||||
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 DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
|
||||
|
||||
-- | For testing and running parse-examples.
|
||||
runParse' :: (Member (Error SomeException) sig, Member Task sig, Monad m, Carrier sig m) => Blob -> m Builder
|
||||
runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
|
||||
|
||||
@ -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, parseSExpressionBuilder, diffSummaryBuilder)
|
||||
import Semantic.API (parseSymbolsBuilder, parseTermBuilder, TermOutputFormat(..), diffSummaryBuilder)
|
||||
import Semantic.CLI
|
||||
import Semantic.IO
|
||||
import Semantic.Task
|
||||
@ -21,9 +21,9 @@ spec = parallel $ do
|
||||
output <- runTask $ readBlobPairs (Right files) >>= runDiff
|
||||
runBuilder output `shouldBe'` expected
|
||||
|
||||
describe "runParse" $
|
||||
for_ parseFixtures $ \ (parseTreeRenderer, runParse, files, expected) ->
|
||||
it ("renders to " <> parseTreeRenderer <> " with files " <> show files) $ do
|
||||
describe "parseTermBuilder" $
|
||||
for_ parseFixtures $ \ (format, runParse, files, expected) ->
|
||||
it ("renders to " <> format <> " with files " <> show files) $ do
|
||||
output <- runTask $ readBlobs (Right files) >>= runParse
|
||||
runBuilder output `shouldBe'` expected
|
||||
where
|
||||
@ -34,11 +34,11 @@ spec = parallel $ do
|
||||
|
||||
parseFixtures :: [(String, [Blob] -> TaskEff Builder, [File], FilePath)]
|
||||
parseFixtures =
|
||||
[ ("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")
|
||||
, ("symbols", parseSymbolsBuilder Serializing.Format.JSON, path'', prefix </> "parse-tree.symbols.json")
|
||||
[ ("s-expression", parseTermBuilder TermSExpression, path, "test/fixtures/ruby/corpus/and-or.parseA.txt")
|
||||
, ("json", parseTermBuilder TermJSONTree, path, prefix </> "parse-tree.json")
|
||||
, ("json", parseTermBuilder TermJSONTree, path', prefix </> "parse-trees.json")
|
||||
, ("json", parseTermBuilder TermJSONTree, [], prefix </> "parse-tree-empty.json")
|
||||
, ("symbols", parseSymbolsBuilder, path'', prefix </> "parse-tree.symbols.json")
|
||||
]
|
||||
where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby]
|
||||
path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby]
|
||||
|
||||
@ -13,14 +13,14 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "parseBlob" $ do
|
||||
it "returns error if given an unknown language (json)" $ do
|
||||
output <- fmap runBuilder . runTask $ runParse JSONTermRenderer [ methodsBlob { blobLanguage = Unknown } ]
|
||||
output <- fmap runBuilder . runTask $ parseTermBuilder TermJSONTree [ methodsBlob { blobLanguage = Unknown } ]
|
||||
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 (parseSExpressionBuilder [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1)
|
||||
runTask (parseTermBuilder TermSExpression [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1)
|
||||
|
||||
it "renders with the specified renderer" $ do
|
||||
output <- fmap runBuilder . runTask $ parseSExpressionBuilder [methodsBlob]
|
||||
output <- fmap runBuilder . runTask $ parseTermBuilder TermSExpression [methodsBlob]
|
||||
output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n"
|
||||
where
|
||||
methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby
|
||||
|
||||
@ -83,7 +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 Semantic.API (parseTermBuilder, TermOutputFormat(..))
|
||||
import System.Exit (die)
|
||||
import Control.Exception (displayException)
|
||||
|
||||
@ -100,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 . parseSExpressionBuilder @[] . pure >>= either (die . displayException) (pure . runBuilder)
|
||||
parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . parseTermBuilder @[] TermSExpression . pure >>= either (die . displayException) (pure . runBuilder)
|
||||
|
||||
-- | Read two files to a BlobPair.
|
||||
readFilePair :: Both FilePath -> IO BlobPair
|
||||
|
||||
Loading…
Reference in New Issue
Block a user