From 706ed5cc0c3e1398595e39e1c83368a4cd9e42a1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 16 Jan 2018 11:39:04 -0800 Subject: [PATCH] Better way to pass around tag fields to the one renderer --- src/Rendering/Renderer.hs | 2 +- src/Semantic.hs | 10 +++++----- src/Semantic/CLI.hs | 13 ++++++------- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 5e9f4954e..a850f2c2c 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -51,7 +51,7 @@ data TermRenderer output where -- | Render to a 'ByteString' formatted as nested s-expressions. SExpressionTermRenderer :: TermRenderer ByteString -- | Render to a list of tags. - TagsTermRenderer :: TermRenderer [Value] + TagsTermRenderer :: TagFields -> TermRenderer [Value] -- | Render to a 'ByteString' formatted as a DOT description of the term. DOTTermRenderer :: TermRenderer ByteString diff --git a/src/Semantic.hs b/src/Semantic.hs index a7aeb9a9b..41d6c6b50 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -41,21 +41,21 @@ import Semantic.Task as Task -- - Built in concurrency where appropriate. -- - Easy to consume this interface from other application (e.g a cmdline or web server app). -parseBlobs :: Output output => TagFields -> TermRenderer output -> [Blob] -> Task ByteString -parseBlobs fields renderer blobs = toOutput' <$> distributeFoldMap (parseBlob fields renderer) blobs +parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString +parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (parseBlob renderer) blobs where toOutput' = case renderer of JSONTermRenderer -> toOutput . renderJSONTerms _ -> toOutput -- | A task to parse a 'Blob' and render the resulting 'Term'. -parseBlob :: TagFields -> TermRenderer output -> Blob -> Task output -parseBlob fields renderer blob@Blob{..} +parseBlob :: TermRenderer output -> Blob -> Task output +parseBlob renderer blob@Blob{..} | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1]) <$> blobLanguage = parse parser blob >>= case renderer of ToCTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToCTerm blob) JSONTermRenderer -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob) SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm - TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags fields blob) + TagsTermRenderer fields -> decorate (declarationAlgebra blob) >=> render (renderToTags fields blob) DOTTermRenderer -> render (renderDOTTerm blob) | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index c7a00893e..3b8700252 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -33,8 +33,8 @@ main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTa runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs -runParse :: SomeRenderer TermRenderer -> TagFields -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString -runParse (SomeRenderer parseTreeRenderer) fields = Semantic.parseBlobs fields parseTreeRenderer <=< Task.readBlobs +runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString +runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs -- | A parser for the application's command-line arguments. -- @@ -77,9 +77,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees") <|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output JSON table of contents summary") - <|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols") + <|> flag' (SomeRenderer . TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols") <*> (option tagFieldsReader (long "fields" <> help "Comma delimited list of specific fields to return (tags output only)." <> metavar "FIELDS") <|> pure defaultTagFields) <|> flag' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output the term as a DOT graph")) - <*> (option fieldsReader (long "fields" <> help "Comma delimited list of specific fields to return (tags output only)." <> metavar "FIELDS") <|> pure defaultTagFields) <*> ( Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) ) @@ -94,9 +93,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) findOption options value = maybe "" fst (find ((== value) . snd) options) - -- Example: --fields=symbol,path,language,kind,line,span - fieldsReader = eitherReader parseFields - parseFields arg = let fields = splitWhen (== ',') arg in + -- Example: semantic parse --tags --fields=symbol,path,language,kind,line,span + tagFieldsReader = eitherReader parseTagFields + parseTagFields arg = let fields = splitWhen (== ',') arg in Right $ TagFields { tagFieldsShowSymbol = (elem "symbol" fields) , tagFieldsShowPath = (elem "path" fields)