From a05f91cede345af739f38cb347dd08e0befd20db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Sep 2019 11:55:31 -0400 Subject: [PATCH] Pass the language mode around with a Reader effect. --- src/Semantic/Api/Symbols.hs | 13 ++++++------- src/Semantic/Api/Terms.hs | 17 +++++++++-------- src/Semantic/CLI.hs | 3 ++- 3 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index d4a326833..93ba48509 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -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 diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index e8e16ac12..5a3500375 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -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 diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index d486523dc..0e3ae2ad9 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -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)"))