github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-25 02:58:36 +03:00
Code Issues Projects Releases Wiki Activity

Pass the language mode around with a Reader effect.

Browse Source
This commit is contained in:
Rob Rix 2019-09-25 11:55:31 -04:00
parent 44f9a11a62
commit a05f91cede
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
3 changed files with 17 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Semantic/Api/Symbols.hs
View File

@ -10,7 +10,6 @@ import Control.Exception
import Control.Lens
import Data.Blob hiding (File (..))
import Data.ByteString.Builder
import Data.Language
import Data.Maybe
import Data.Term
import qualified Data.Text as T
@ -31,7 +30,7 @@ import Tags.Tagging
legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
where
go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m [Legacy.File]
go :: ParseEffects sig m => Blob -> m [Legacy.File]
go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile))
where
emptyFile = tagsToFile []
@ -55,13 +54,13 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
, symbolSpan = converting #? span
}
parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> PerLanguageModes -> t Blob -> m Builder
parseSymbolsBuilder format modes blobs = parseSymbols modes blobs >>= serialize format
parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => PerLanguageModes -> t Blob -> m ParseTreeSymbolResponse
parseSymbols _ blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
where
go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m File
go :: ParseEffects sig m => Blob -> m File
go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
where
blobLanguage' = blobLanguage blob

17
src/Semantic/Api/Terms.hs
View File

@ -16,6 +16,7 @@ module Semantic.Api.Terms
import Analysis.ConstructorName (ConstructorName)
import Control.Effect.Error
import Control.Effect.Reader
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
@ -69,13 +70,13 @@ data TermOutputFormat
deriving (Eq, Show)
parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, MonadIO m)
=> TermOutputFormat -> PerLanguageModes -> t Blob -> m Builder
parseTermBuilder TermJSONTree _ = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs.
parseTermBuilder TermJSONGraph _ = termGraph >=> serialize Format.JSON
parseTermBuilder TermSExpression _ = distributeFoldMap sexpTerm
parseTermBuilder TermDotGraph _ = distributeFoldMap dotGraphTerm
parseTermBuilder TermShow _ = distributeFoldMap showTerm
parseTermBuilder TermQuiet _ = distributeFoldMap quietTerm
=> TermOutputFormat -> t Blob -> m Builder
parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs.
parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.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
@ -101,7 +102,7 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
in stringUtf8 (status <> "\t" <> show (blobLanguage blob) <> "\t" <> blobPath blob <> "\t" <> show duration <> " ms\n")
type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m)
type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Task sig, Carrier sig m)
type TermConstraints =
'[ Taggable

3
src/Semantic/CLI.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE ApplicativeDo #-}
module Semantic.CLI (main) where
import Control.Effect.Reader
import Control.Exception as Exc (displayException)
import Data.Blob
import Data.Blob.IO
@ -144,7 +145,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
<|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
<|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= renderer languageModes
pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer
tsParseCommand :: Mod CommandFields (Task.TaskEff Builder)
tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Generate raw tree-sitter parse trees for path(s)"))