Field selection for tag output

src/Rendering/Renderer.hs

@@ -15,6 +15,8 @@ module Rendering.Renderer
 , renderDOTDiff
 , renderDOTTerm
 , Summaries(..)
+, TagFields(..)
+, defaultTagFields
 ) where
 
 import Data.Aeson (Value)

src/Rendering/Tag.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Rendering.Tag
 ( renderToTags
+, TagFields(..)
+, defaultTagFields
 ) where
 
 import Analysis.Declaration
@@ -15,33 +17,57 @@ import qualified Data.Text as T
 import Rendering.TOC
 
 -- | Render a 'Term' to a ctags like output (See 'Tag').
-renderToTags :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> [Value]
-renderToTags Blob{..} = fmap toJSON . termToC blobPath
+renderToTags :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => TagFields -> Blob -> Term f (Record fields) -> [Value]
+renderToTags fields Blob{..} = fmap toJSON . termToC fields blobPath
   where
-    termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => FilePath -> Term f (Record fields) -> [Tag]
-    termToC path = mapMaybe (tagSummary path "unchanged") . termTableOfContentsBy declaration
+    termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => TagFields -> FilePath -> Term f (Record fields) -> [Tag]
+    termToC fields path = mapMaybe (tagSummary fields path "unchanged") . termTableOfContentsBy declaration
 
 -- | Construct a 'Tag' from a node annotation and a change type label.
-tagSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => FilePath -> T.Text -> Record fields -> Maybe Tag
-tagSummary path _ record = case getDeclaration record of
+tagSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => TagFields -> FilePath -> T.Text -> Record fields -> Maybe Tag
+tagSummary TagFields{..} path _ record = case getDeclaration record of
   Just ErrorDeclaration{} -> Nothing
-  Just declaration -> Just $ Tag (declarationIdentifier declaration) (T.pack path) (T.pack . show <$> declarationLanguage declaration) (toCategoryName declaration) (declarationText declaration) (getField record)
+  Just declaration -> Just $ Tag
+    { tagSymbol = when tagFieldsShowSymbol (declarationIdentifier declaration)
+    , tagPath = when tagFieldsShowPath (T.pack path)
+    , tagLanguage = if tagFieldsShowLanguage then (T.pack . show <$> declarationLanguage declaration) else Nothing
+    , tagKind = when tagFieldsShowKind (toCategoryName declaration)
+    , tagLine = when tagFieldsShowLine (declarationText declaration)
+    , tagSpan = when tagFieldsShowSpan (getField record)
+    }
   _ -> Nothing
 
-data Tag
-  = Tag { tagSymbol :: T.Text
-        , tagPath :: T.Text
-        , tagLanguage :: Maybe T.Text
-        , tagKind :: T.Text
-        , tagLine :: T.Text
-        , tagSpan :: Span
-      }
-  deriving (Generic, Eq, Show)
+data Tag = Tag
+  { tagSymbol :: Maybe T.Text
+  , tagPath :: Maybe T.Text
+  , tagLanguage :: Maybe T.Text
+  , tagKind :: Maybe T.Text
+  , tagLine :: Maybe T.Text
+  , tagSpan :: Maybe Span
+  } deriving (Generic, Eq, Show)
 
 instance ToJSON Tag where
-  toJSON Tag{..} = object [ "symbol" .= tagSymbol
+  toJSON Tag{..} = objectWithoutNulls [ "symbol" .= tagSymbol
                           , "path" .= tagPath
                           , "language" .= tagLanguage
                           , "kind" .= tagKind
                           , "line" .= tagLine
                           , "span" .= tagSpan ]
+    where objectWithoutNulls = object . filter (\(_, v) -> v /= Null)
+
+when :: Bool -> a -> Maybe a
+when True a = Just a
+when False _ = Nothing
+
+data TagFields = TagFields
+  { tagFieldsShowSymbol :: Bool
+  , tagFieldsShowPath :: Bool
+  , tagFieldsShowLanguage :: Bool
+  , tagFieldsShowKind :: Bool
+  , tagFieldsShowLine :: Bool
+  , tagFieldsShowSpan :: Bool
+  }
+  deriving (Eq, Show)
+
+defaultTagFields :: TagFields
+defaultTagFields = TagFields True True True True True True

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 => TermRenderer output -> [Blob] -> Task ByteString
-parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (parseBlob renderer) blobs
+parseBlobs :: Output output => TagFields -> TermRenderer output -> [Blob] -> Task ByteString
+parseBlobs fields renderer blobs = toOutput' <$> distributeFoldMap (parseBlob fields renderer) blobs
   where toOutput' = case renderer of
           JSONTermRenderer -> toOutput . renderJSONTerms
           _ -> toOutput
 
 -- | A task to parse a 'Blob' and render the resulting 'Term'.
-parseBlob :: TermRenderer output -> Blob -> Task output
-parseBlob renderer blob@Blob{..}
+parseBlob :: TagFields -> TermRenderer output -> Blob -> Task output
+parseBlob fields 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 blob)
+    TagsTermRenderer        -> decorate (declarationAlgebra blob)                     >=> render (renderToTags fields blob)
     DOTTermRenderer         ->                                                            render (renderDOTTerm blob)
   | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
 

src/Semantic/CLI.hs

@@ -26,14 +26,15 @@ import System.IO (Handle, stdin, stdout)
 import qualified Semantic (parseBlobs, diffBlobPairs)
 import Text.Read
 
+
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
 runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString
 runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
 
-runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString
-runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
+runParse :: SomeRenderer TermRenderer -> TagFields -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString
+runParse (SomeRenderer parseTreeRenderer) fields = Semantic.parseBlobs fields parseTreeRenderer <=< Task.readBlobs
 
 -- | A parser for the application's command-line arguments.
 --
@@ -78,6 +79,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
           <|> flag'                                        (SomeRenderer ToCTermRenderer)         (long "toc" <> help "Output JSON table of contents summary")
           <|> flag'                                        (SomeRenderer TagsTermRenderer)        (long "tags" <> help "Output JSON tags/symbols")
           <|> 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) )
 
@@ -91,3 +93,15 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
     optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
     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
+                      Right $ TagFields
+                        { tagFieldsShowSymbol = (elem "symbol" fields)
+                        , tagFieldsShowPath = (elem "path" fields)
+                        , tagFieldsShowLanguage = (elem "language" fields)
+                        , tagFieldsShowKind = (elem "kind" fields)
+                        , tagFieldsShowLine = (elem "line" fields)
+                        , tagFieldsShowSpan = (elem "span" fields)
+                        }