github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-29 02:44: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 Control.Lens
import Data.Blob hiding (File (..)) import Data.Blob hiding (File (..))
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Language
import Data.Maybe import Data.Maybe
import Data.Term import Data.Term
import qualified Data.Text as T 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 :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
where 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)) go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile))
where where
emptyFile = tagsToFile [] emptyFile = tagsToFile []
@ -55,13 +54,13 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
, symbolSpan = converting #? span , symbolSpan = converting #? span
} }
parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> PerLanguageModes -> t Blob -> m Builder parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
parseSymbolsBuilder format modes blobs = parseSymbols modes blobs >>= serialize format parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => PerLanguageModes -> t Blob -> m ParseTreeSymbolResponse parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
parseSymbols _ blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
where 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)) go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException e) -> pure $ errorFile (show e))
where where
blobLanguage' = blobLanguage blob blobLanguage' = blobLanguage blob

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

@ -16,6 +16,7 @@ module Semantic.Api.Terms
import Analysis.ConstructorName (ConstructorName) import Analysis.ConstructorName (ConstructorName)
import Control.Effect.Error import Control.Effect.Error
import Control.Effect.Reader
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -69,13 +70,13 @@ data TermOutputFormat
deriving (Eq, Show) deriving (Eq, Show)
parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, MonadIO m) parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, MonadIO m)
=> TermOutputFormat -> PerLanguageModes -> t Blob -> m Builder => 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 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 TermJSONGraph = termGraph >=> serialize Format.JSON
parseTermBuilder TermSExpression _ = distributeFoldMap sexpTerm parseTermBuilder TermSExpression = distributeFoldMap sexpTerm
parseTermBuilder TermDotGraph _ = distributeFoldMap dotGraphTerm parseTermBuilder TermDotGraph = distributeFoldMap dotGraphTerm
parseTermBuilder TermShow _ = distributeFoldMap showTerm parseTermBuilder TermShow = distributeFoldMap showTerm
parseTermBuilder TermQuiet _ = distributeFoldMap quietTerm parseTermBuilder TermQuiet = distributeFoldMap quietTerm
jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
jsonTerm blob = (doParse blob >>= withSomeTerm (pure . renderJSONTerm blob)) `catchError` jsonError blob 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") 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 = type TermConstraints =
'[ Taggable '[ Taggable

3
src/Semantic/CLI.hs
View File

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