tricorder-types 0.5.0.0 → 0.6.0.0
raw patch · 46 files changed
+1417/−653 lines, 46 filesdep +effectful
Dependencies added: effectful
Files
- CHANGELOG.md +15/−0
- src/Tricorder/API/Args/Deprecated.hs +76/−0
- src/Tricorder/API/Command.hs +114/−0
- src/Tricorder/API/Command/Args.hs +158/−0
- src/Tricorder/API/Daemon/Args.hs +56/−0
- src/Tricorder/API/Daemon/Command.hs +22/−0
- src/Tricorder/API/FieldMask.hs +42/−0
- src/Tricorder/API/FieldMask/Args.hs +41/−0
- src/Tricorder/API/FieldMask/Projection.hs +68/−0
- src/Tricorder/API/FieldMask/Schema.hs +77/−0
- src/Tricorder/API/Force.hs +18/−0
- src/Tricorder/API/Force/Args.hs +26/−0
- src/Tricorder/API/IfDaemonIsStopped.hs +22/−0
- src/Tricorder/API/IfDaemonIsStopped/Args.hs +15/−0
- src/Tricorder/API/OutputFormat.hs +21/−0
- src/Tricorder/API/OutputFormat/Args.hs +15/−0
- src/Tricorder/API/Test.hs +52/−0
- src/Tricorder/API/Test/Args.hs +93/−0
- src/Tricorder/API/Test/SuiteView.hs +51/−0
- src/Tricorder/API/Test/SuiteView/Schema.hs +36/−0
- src/Tricorder/API/TestFilter.hs +26/−0
- src/Tricorder/API/TestFilter/Args.hs +19/−0
- src/Tricorder/API/WaitMode.hs +21/−0
- src/Tricorder/API/WaitMode/Args.hs +13/−0
- src/Tricorder/CLI/Command.hs +0/−125
- src/Tricorder/CLI/Command/Daemon.hs +0/−14
- src/Tricorder/CLI/Command/IfDaemonIsStopped.hs +0/−21
- src/Tricorder/CLI/Command/OutputFormat.hs +0/−21
- src/Tricorder/CLI/Command/Test.hs +0/−52
- src/Tricorder/CLI/Command/TestFilter.hs +0/−25
- src/Tricorder/CLI/Command/WaitMode.hs +0/−21
- src/Tricorder/FieldMask.hs +0/−42
- src/Tricorder/FieldMask/Args.hs +0/−41
- src/Tricorder/FieldMask/Projection.hs +0/−68
- src/Tricorder/FieldMask/Schema.hs +0/−53
- src/Tricorder/SourceLookup/ModuleSourceResult.hs +25/−0
- src/Tricorder/SourceLookup/PackageId.hs +25/−0
- src/Tricorder/SourceLookup/ReexportLimits.hs +22/−0
- test/Unit/Tricorder/API/FieldMask/ArgsSpec.hs +55/−0
- test/Unit/Tricorder/API/FieldMask/ProjectionSpec.hs +50/−0
- test/Unit/Tricorder/API/FieldMask/SchemaSpec.hs +50/−0
- test/Unit/Tricorder/API/SuiteView/SchemaSpec.hs +60/−0
- test/Unit/Tricorder/FieldMask/ArgsSpec.hs +0/−55
- test/Unit/Tricorder/FieldMask/ProjectionSpec.hs +0/−50
- test/Unit/Tricorder/FieldMask/SchemaSpec.hs +0/−50
- tricorder-types.cabal +33/−15
CHANGELOG.md view
@@ -7,6 +7,21 @@ ## [Unreleased] +## [0.6.0.0] - 2026-10-23++### Added++- Moved all argument parsing functionality from `tricorder` to+ `tricorder-types` for module locality.++### Changed++- `Tricorder.API.Daemon.Command.DaemonCommand` renamed to+ `Tricorder.API.Daemon.Command.Command`.+- `Tricorder.API` moved to `Tricorder.API.Command`.+- `Tricorder.API.Args` moved to `Tricorder.API.Command.Args`.+- `Tricorder.API.Command.commandToArgs` renamed to `Tricorder.API.Command.toArgs`.+ ## [0.5.0.0] - 2026-10-20 ### Added
+ src/Tricorder/API/Args/Deprecated.hs view
@@ -0,0 +1,76 @@+module Tricorder.API.Args.Deprecated (parser) where++import Options.Applicative+ ( Parser+ , command+ , commandGroup+ , flag+ , help+ , hidden+ , hsubparser+ , info+ , long+ , progDescDoc+ )++import Options.Applicative.Help qualified as Doc++import Tricorder.API.Command (Command (..), TestOptions (..))++import Tricorder.API.Daemon.Args qualified as Daemon.Args+import Tricorder.API.Daemon.Command qualified as Daemon.Command+import Tricorder.API.WaitMode.Args qualified as WaitMode.Args+++parser :: Parser Command+parser =+ hsubparser+ $ mconcat+ [ hidden+ , commandGroup "Deprecated:"+ , command+ "start"+ $ info (pure $ Daemon Daemon.Command.Start)+ $ progDescDoc+ $ Just+ $ "Start the daemon (no-op if already running.)"+ <> Doc.line+ <> "Use 'daemon start' instead."+ , command+ "stop"+ $ info (Daemon <$> Daemon.Args.stopParser)+ $ progDescDoc+ $ Just+ $ "Stop the daemon."+ <> Doc.line+ <> "Use 'daemon stop' instead."+ , command+ "restart"+ $ info (Daemon <$> Daemon.Args.restartParser)+ $ progDescDoc+ $ Just+ $ "Restart the daemon."+ <> Doc.line+ <> "Use 'daemon restart' instead."+ , command "test-results"+ $ info testResultsParser+ $ progDescDoc+ $ Just+ $ "Show output from the latest test run"+ <> Doc.line+ <> "Use `test suites` instead."+ ]+++testResultsParser :: Parser Command+testResultsParser =+ TestResults+ <$> ( TestOptions+ <$> flag+ False+ True+ ( long "failed"+ <> help "Only show output from failed test suites"+ )+ <*> WaitMode.Args.parser+ )
+ src/Tricorder/API/Command.hs view
@@ -0,0 +1,114 @@+module Tricorder.API.Command+ ( Command (..)+ , EvalCommentsOptions (..)+ , LogMode (..)+ , SourceOptions (..)+ , StatusOptions (..)+ , TestOptions (..)+ , Verbosity (..)+ , toArgs+ )+where++import Tricorder.API.IfDaemonIsStopped (IfDaemonIsStopped)+import Tricorder.API.OutputFormat (OutputFormat (..))+import Tricorder.API.WaitMode (WaitMode)+import Tricorder.SourceLookup.SourceQuery (SourceQuery, renderSourceQuery)++import Tricorder.API.Daemon.Command qualified as Daemon (Command)+import Tricorder.API.Daemon.Command qualified as Daemon.Command+import Tricorder.API.OutputFormat qualified as OutputFormat+import Tricorder.API.Test qualified as Test+import Tricorder.API.WaitMode qualified as WaitMode+++data Verbosity+ = Concise+ | Verbose+ deriving stock (Eq)+++data LogMode = ShowLog | ShowLogPath+++data StatusOptions = StatusOptions+ { wait :: WaitMode+ , format :: OutputFormat+ , verbosity :: Verbosity+ , expand :: Maybe Int+ , ifDaemonIsStopped :: IfDaemonIsStopped+ }+++data TestOptions = TestOptions+ { failedOnly :: Bool+ , wait :: WaitMode+ }+++data EvalCommentsOptions = EvalCommentsOptions+ { wait :: WaitMode+ , format :: OutputFormat+ , ifDaemonIsStopped :: IfDaemonIsStopped+ }+++data SourceOptions = SourceOptions+ { queries :: [SourceQuery]+ , maxDepth :: Maybe Word+ -- ^ Most re-export hops to follow for a symbol query; 'Nothing' is the default.+ , maxModules :: Maybe Word+ -- ^ Most modules to read while following re-exports; 'Nothing' is the default.+ }+++data Command+ = Status StatusOptions+ | -- | DEPRECATED: Use 'Test' instead.+ TestResults TestOptions+ | Test Test.Command+ | UI+ | Log LogMode+ | Source SourceOptions+ | EvalComments EvalCommentsOptions+ | Daemon Daemon.Command+++-- | Render a 'Command' to the argument list the @tricorder@ CLI expects+-- (subcommand name followed by flags) — the inverse of the parser in+-- "Tricorder.CLI.Arguments". Kept next to 'Command' so a new field or+-- constructor forces both the parser and this renderer to be updated+-- together; this is what @tricorder-mcp@ uses to invoke @tricorder@ without+-- duplicating flag names.+toArgs :: Command -> [String]+toArgs = \case+ Status (StatusOptions {wait, format, verbosity, expand}) ->+ "status"+ : WaitMode.toArgs wait+ <> OutputFormat.toArgs format+ <> verbosityArgs verbosity+ <> maybe [] (\n -> ["--expand", show n]) expand+ TestResults (TestOptions {failedOnly, wait}) ->+ "test-results" : failedArgs failedOnly <> WaitMode.toArgs wait+ Test testCommand -> "test" : Test.toArgs testCommand+ UI -> ["ui"]+ Log ShowLogPath -> ["log", "--print-path"]+ Log ShowLog -> ["log"]+ Source (SourceOptions {queries, maxDepth, maxModules}) ->+ "source"+ : maybe [] (\n -> ["--max-depth", show n]) maxDepth+ <> maybe [] (\n -> ["--max-modules", show n]) maxModules+ <> map renderSourceQuery queries+ EvalComments (EvalCommentsOptions {wait, format}) ->+ "eval-comments" : WaitMode.toArgs wait <> OutputFormat.toArgs format+ Daemon daemonCommand -> "daemon" : Daemon.Command.toArgs daemonCommand+++verbosityArgs :: Verbosity -> [String]+verbosityArgs Verbose = ["--verbose"]+verbosityArgs Concise = []+++failedArgs :: Bool -> [String]+failedArgs True = ["--failed"]+failedArgs False = []
+ src/Tricorder/API/Command/Args.hs view
@@ -0,0 +1,158 @@+module Tricorder.API.Command.Args+ ( parser+ )+where++import Options.Applicative+ ( Parser+ , ReadM+ , argument+ , auto+ , command+ , eitherReader+ , flag+ , help+ , hsubparser+ , info+ , long+ , metavar+ , option+ , progDesc+ , readerError+ , short+ )++import Tricorder.API.Command+ ( Command (..)+ , EvalCommentsOptions (..)+ , LogMode (..)+ , SourceOptions (..)+ , StatusOptions (..)+ , Verbosity (..)+ )+import Tricorder.SourceLookup.ReexportLimits (ReexportLimits (..), defaultReexportLimits)+import Tricorder.SourceLookup.SourceQuery (SourceQuery, parseSourceQuery)++import Tricorder.API.Args.Deprecated qualified as Args.Deprecated+import Tricorder.API.Daemon.Args qualified as Daemon.Args+import Tricorder.API.IfDaemonIsStopped.Args qualified as IfDaemonIsStopped.Args+import Tricorder.API.OutputFormat.Args qualified as OutputFormat.Args+import Tricorder.API.Test.Args qualified as Test.Args+import Tricorder.API.WaitMode.Args qualified as WaitMode.Args+++parser :: Parser Command+parser =+ asum+ [ hsubparser+ $ mconcat+ [ command "ui"+ $ info (pure UI)+ $ progDesc "Auto-refreshing terminal display."+ , command "status"+ $ info statusParser+ $ progDesc "Print build diagnostics (--json for machine-readable output.)"+ , command "test" $ Test <$> Test.Args.parser+ , command "source"+ $ info sourceParser+ $ progDesc "Print the Haskell source of one or more project or installed modules."+ , command "eval-comments"+ $ info evalCommentsParser+ $ progDesc "Show eval comments from the latest build."+ , command "daemon" $ Daemon <$> Daemon.Args.parser+ , command "log"+ $ info logParser+ $ progDesc "Show daemon log output."+ ]+ , Args.Deprecated.parser+ ]+++logParser :: Parser Command+logParser =+ Log <$> pathFlag+ where+ pathFlag =+ flag+ ShowLog+ ShowLogPath+ $ long "print-path"+ <> help "Print the path to the log file instead of its contents"+++statusParser :: Parser Command+statusParser =+ Status+ <$> ( StatusOptions+ <$> WaitMode.Args.parser+ <*> OutputFormat.Args.parser+ <*> flag+ Concise+ Verbose+ ( long "verbose"+ <> short 'v'+ <> help "Print full GHC message body under each diagnostic, and full test suite error messages"+ )+ <*> optional+ ( option+ auto+ ( long "expand"+ <> metavar "N"+ <> help "Print full GHC message body for diagnostic #N"+ )+ )+ <*> IfDaemonIsStopped.Args.parser+ )+++sourceParser :: Parser Command+sourceParser =+ Source+ <$> ( SourceOptions+ <$> some+ ( argument+ queryReader+ $ metavar "Module[#function]"+ <> help "Module or Module#function"+ )+ <*> optional+ ( option+ nonNegative+ $ long "max-depth"+ <> metavar "N"+ <> help+ ( "Follow at most N re-export hops when a symbol is not defined in the queried module (default: "+ <> show defaultReexportLimits.maxDepth+ <> ")"+ )+ )+ <*> optional+ ( option+ nonNegative+ $ long "max-modules"+ <> metavar "N"+ <> help+ ( "Read at most N modules while following re-exports (default: "+ <> show defaultReexportLimits.maxModules+ <> ")"+ )+ )+ )+ where+ nonNegative = do+ n <- auto+ if n < 0 then readerError "must be a non-negative integer" else pure n+++evalCommentsParser :: Parser Command+evalCommentsParser =+ EvalComments+ <$> ( EvalCommentsOptions+ <$> WaitMode.Args.parser+ <*> OutputFormat.Args.parser+ <*> IfDaemonIsStopped.Args.parser+ )+++queryReader :: ReadM SourceQuery+queryReader = eitherReader $ Right . parseSourceQuery . toText
+ src/Tricorder/API/Daemon/Args.hs view
@@ -0,0 +1,56 @@+module Tricorder.API.Daemon.Args+ ( parser+ , infoParser+ , startParser+ , stopParser+ , restartParser+ )+where++import Options.Applicative (Parser, ParserInfo, command, hsubparser, info, progDesc)++import Tricorder.API.Daemon.Command (Command (..))++import Tricorder.API.Force.Args qualified as Force.Args+import Tricorder.API.OutputFormat.Args qualified as OutputFormat.Args+++parser :: ParserInfo Command+parser = info subParser $ progDesc "Manage the daemon itself."+++subParser :: Parser Command+subParser =+ hsubparser+ $ mconcat+ [ command "info"+ $ info infoParser+ $ progDesc "Information about the daemon."+ , command "start"+ $ info startParser+ $ progDesc "Start the daemon (no-op if already running.)"+ , command "stop"+ $ info stopParser+ $ progDesc "Stop the daemon."+ , command "restart"+ $ info restartParser+ $ progDesc "Restart the daemon."+ ]+++infoParser :: Parser Command+infoParser = Info <$> OutputFormat.Args.parser+++startParser :: Parser Command+startParser = pure Start+++stopParser :: Parser Command+stopParser =+ Stop <$> Force.Args.parser "Ignore waiting queries when stopping the daemon."+++restartParser :: Parser Command+restartParser =+ Restart <$> Force.Args.parser "Ignore watiting queries when restarting the daemon."
+ src/Tricorder/API/Daemon/Command.hs view
@@ -0,0 +1,22 @@+module Tricorder.API.Daemon.Command (Command (..), toArgs) where++import Tricorder.API.Force (Force)+import Tricorder.API.OutputFormat (OutputFormat)++import Tricorder.API.Force qualified as Force+import Tricorder.API.OutputFormat qualified as OutputFormat+++data Command+ = Start+ | Stop Force+ | Restart Force+ | Info OutputFormat+++toArgs :: Command -> [String]+toArgs = \case+ Start -> ["start"]+ Stop force' -> "stop" : Force.toArgs force'+ Restart force' -> "restart" : Force.toArgs force'+ Info format -> "info" : OutputFormat.toArgs format
+ src/Tricorder/API/FieldMask.hs view
@@ -0,0 +1,42 @@+module Tricorder.API.FieldMask+ ( FieldMask (..)+ , Field (..)+ , render+ , toArgs+ , fieldsFlagName+ )+where++import Data.Text qualified as T+++-- | A selection of fields to include in a response, in the style of Google's+-- partial-response @fields@ parameter:+--+-- @+-- name,status,cases(description,failure)+-- @+newtype FieldMask = FieldMask {getFields :: NonEmpty Field}+ deriving stock (Eq, Show)+++data Field = Field+ { name :: Text+ , subFields :: Maybe FieldMask+ -- ^ 'Nothing' selects the field's whole value.+ }+ deriving stock (Eq, Show)+++render :: FieldMask -> Text+render (FieldMask fields) = T.intercalate "," $ renderField <$> toList fields+ where+ renderField field = field.name <> maybe "" (\sub -> "(" <> render sub <> ")") field.subFields+++toArgs :: Maybe FieldMask -> [String]+toArgs = maybe [] \mask -> ["--" <> fieldsFlagName, toString $ render mask]+++fieldsFlagName :: String+fieldsFlagName = "fields"
+ src/Tricorder/API/FieldMask/Args.hs view
@@ -0,0 +1,41 @@+module Tricorder.API.FieldMask.Args (parser, parse) where++import Options.Applicative (Mod, OptionFields, Parser, eitherReader, long, metavar, option)+import Text.Megaparsec (Parsec, between, eof, errorBundlePretty, takeWhile1P)+import Text.Megaparsec.Char (space)++import Data.Char qualified as Char+import Text.Megaparsec qualified as Megaparsec+import Text.Megaparsec.Char.Lexer qualified as Lexer++import Tricorder.API.FieldMask (Field (..), FieldMask (..), fieldsFlagName)+++parser :: Mod OptionFields FieldMask -> Parser (Maybe FieldMask)+parser extraMods =+ optional+ $ option (eitherReader $ first toString . parse . toText)+ $ long fieldsFlagName+ <> metavar "FIELDS"+ <> extraMods+++-- | Parse a field mask such as @name,status,cases(description,failure)@.+parse :: Text -> Either Text FieldMask+parse =+ first (toText . errorBundlePretty)+ . Megaparsec.parse (space *> fieldMask <* eof) "fields"+ where+ fieldMask :: TParser FieldMask+ fieldMask = FieldMask <$> ((:|) <$> field <*> many (symbol "," *> field))++ field :: TParser Field+ field = Field <$> lexeme fieldName <*> optional (between (symbol "(") (symbol ")") fieldMask)++ fieldName = takeWhile1P (Just "field name") \c -> Char.isAlphaNum c || c == '_'++ lexeme = Lexer.lexeme space+ symbol = Lexer.symbol space+++type TParser = Parsec Void Text
+ src/Tricorder/API/FieldMask/Projection.hs view
@@ -0,0 +1,68 @@+-- | Parsing field masks, checking them against the shape of a response, and+-- projecting response values down to the selected fields.+module Tricorder.API.FieldMask.Projection+ ( Projection (..)+ , project+ , renderYaml+ )+where++import Data.Aeson (ToJSON (..), Value (..), object, pairs, (.=))++import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Yaml.Builder qualified as Yaml++import Tricorder.API.FieldMask.Schema (Schema (..))+++-- | A JSON value cut down to the fields of a 'Schema', with its fields in+-- schema order.+data Projection+ = PObject [(Text, Projection)]+ | PArray [Projection]+ | PScalar Value+ deriving stock (Eq, Show)+++instance ToJSON Projection where+ toJSON = \case+ PObject fields -> object [Key.fromText name .= value | (name, value) <- fields]+ PArray values -> toJSON values+ PScalar value -> value+ toEncoding = \case+ PObject fields -> pairs $ foldMap (\(name, value) -> Key.fromText name .= value) fields+ PArray values -> toEncoding values+ PScalar value -> toEncoding value+++-- | Keep only the fields in the 'Schema'. Arrays are projected element-wise,+-- and fields that are missing or @null@ are left out.+project :: Schema -> Value -> Projection+project schema@(Schema fields) = \case+ Array values -> PArray $ project schema <$> toList values+ Object obj ->+ PObject+ [ (name, maybe PScalar project sub value)+ | (name, sub) <- fields+ , Just value <- [KeyMap.lookup (Key.fromText name) obj]+ , value /= Null+ ]+ value -> PScalar value+++renderYaml :: Projection -> Text+renderYaml = decodeUtf8 . Yaml.toByteString . toYaml+ where+ toYaml = \case+ PObject fields -> Yaml.mapping $ second toYaml <$> fields+ PArray values -> Yaml.array $ toYaml <$> values+ PScalar value -> valueToYaml value++ valueToYaml = \case+ Object obj -> Yaml.mapping $ bimap Key.toText valueToYaml <$> KeyMap.toList obj+ Array values -> Yaml.array $ valueToYaml <$> toList values+ String text -> Yaml.string text+ Number number -> Yaml.scientific number+ Bool b -> Yaml.bool b+ Null -> Yaml.null
+ src/Tricorder/API/FieldMask/Schema.hs view
@@ -0,0 +1,77 @@+module Tricorder.API.FieldMask.Schema+ ( Schema (..)+ , leaf+ , nested+ , select+ , render+ )+where++import Options.Applicative.Help (Doc)++import Data.List qualified as List+import Data.Text qualified as T+import Options.Applicative.Help qualified as Doc++import Tricorder.API.FieldMask (Field (..), FieldMask (..))+++-- | The fields available in a response, in the order they are shown by+-- default. Fields without a nested 'Schema' are shown as-is.+--+-- A 'Schema' narrowed down by 'select' describes exactly what to show.+newtype Schema = Schema [(Text, Maybe Schema)]+ deriving stock (Eq, Show)+++leaf :: Text -> (Text, Maybe Schema)+leaf name = (name, Nothing)+++nested :: Text -> [(Text, Maybe Schema)] -> (Text, Maybe Schema)+nested name fields = (name, Just $ Schema fields)+++-- | Narrow a 'Schema' down to the fields of a 'FieldMask', keeping the order+-- the fields were requested in. Fails on fields the schema does not have.+select :: Schema -> FieldMask -> Either Text Schema+select = go []+ where+ go path (Schema available) (FieldMask requested) =+ Schema <$> traverse (selectField path available) (toList requested)++ selectField path available field =+ case (field.subFields, List.lookup field.name available) of+ (_, Nothing) ->+ Left+ $ "unknown field "+ <> quote (fieldPath path field.name)+ <> ", expected one of: "+ <> T.intercalate ", " (fst <$> available)+ (Nothing, Just schema) -> Right (field.name, schema)+ (Just mask, Just (Just schema)) -> (field.name,) . Just <$> go (field.name : path) schema mask+ (Just _, Just Nothing) ->+ Left $ "field " <> quote (fieldPath path field.name) <> " has no sub-fields"++ fieldPath path name = T.intercalate "." $ reverse $ name : path+ quote name = "'" <> name <> "'"+++render :: Schema -> [Doc]+render (Schema fields) = renderField <$> fields+++renderField :: (Text, Maybe Schema) -> Doc+renderField (name, sub) =+ Doc.pretty name+ <> maybe+ Doc.emptyDoc+ ( \nestedSchema ->+ Doc.enclose+ "("+ ")"+ $ Doc.sep+ $ Doc.punctuate ","+ $ render nestedSchema+ )+ sub
+ src/Tricorder/API/Force.hs view
@@ -0,0 +1,18 @@+module Tricorder.API.Force+ ( Force (..)+ , toArgs+ , forceFlagName+ )+where+++data Force = Force | NoForce+++toArgs :: Force -> [String]+toArgs Force = ["--" <> forceFlagName]+toArgs NoForce = []+++forceFlagName :: String+forceFlagName = "force"
+ src/Tricorder/API/Force/Args.hs view
@@ -0,0 +1,26 @@+module Tricorder.API.Force.Args+ ( parser+ , forceFlagName+ , forceShortFlagName+ )+where++import Options.Applicative (Parser, flag, help, long, short)++import Tricorder.API.Force (Force)++import Tricorder.API.Force qualified as Force+++parser :: String -> Parser Force+parser helpText =+ flag Force.NoForce Force.Force+ $ short forceShortFlagName <> long forceFlagName <> help helpText+++forceFlagName :: String+forceFlagName = "force"+++forceShortFlagName :: Char+forceShortFlagName = 'f'
+ src/Tricorder/API/IfDaemonIsStopped.hs view
@@ -0,0 +1,22 @@+module Tricorder.API.IfDaemonIsStopped+ ( IfDaemonIsStopped (..)+ , toArgs+ , startDaemonFlagName+ )+where+++data IfDaemonIsStopped+ = StartDaemon+ | DoNothing+ deriving stock (Eq)+++toArgs :: IfDaemonIsStopped -> [String]+toArgs = \case+ StartDaemon -> ["--" <> startDaemonFlagName]+ DoNothing -> []+++startDaemonFlagName :: String+startDaemonFlagName = "start-daemon"
+ src/Tricorder/API/IfDaemonIsStopped/Args.hs view
@@ -0,0 +1,15 @@+module Tricorder.API.IfDaemonIsStopped.Args (parser) where++import Options.Applicative (Parser, flag, help, long, short)++import Tricorder.API.IfDaemonIsStopped (IfDaemonIsStopped (..), startDaemonFlagName)+++parser :: Parser IfDaemonIsStopped+parser =+ flag+ DoNothing+ StartDaemon+ $ long startDaemonFlagName+ <> short 'd'+ <> help "Start the daemon if it is not already running."
+ src/Tricorder/API/OutputFormat.hs view
@@ -0,0 +1,21 @@+module Tricorder.API.OutputFormat+ ( OutputFormat (..)+ , toArgs+ , jsonOutputFlagName+ )+where+++data OutputFormat+ = TextOutput+ | JsonOutput+ deriving stock (Eq, Show)+++toArgs :: OutputFormat -> [String]+toArgs JsonOutput = ["--" <> jsonOutputFlagName]+toArgs TextOutput = []+++jsonOutputFlagName :: String+jsonOutputFlagName = "json"
+ src/Tricorder/API/OutputFormat/Args.hs view
@@ -0,0 +1,15 @@+module Tricorder.API.OutputFormat.Args (parser) where++import Options.Applicative (Parser, flag, help, long, short)++import Tricorder.API.OutputFormat (OutputFormat (..), jsonOutputFlagName)+++parser :: Parser OutputFormat+parser =+ flag+ TextOutput+ JsonOutput+ $ long jsonOutputFlagName+ <> short 'j'+ <> help "Output full build state as JSON"
+ src/Tricorder/API/Test.hs view
@@ -0,0 +1,52 @@+module Tricorder.API.Test+ ( Command (..)+ , SuitesOptions (..)+ , SuiteName+ , toArgs+ )+where++import Prelude hiding (All, filter)++import Tricorder.API.FieldMask (FieldMask)+import Tricorder.API.IfDaemonIsStopped (IfDaemonIsStopped)+import Tricorder.API.OutputFormat (OutputFormat)+import Tricorder.API.TestFilter (TestFilter)+import Tricorder.API.WaitMode (WaitMode)++import Tricorder.API.FieldMask qualified as FieldMask+import Tricorder.API.IfDaemonIsStopped qualified as IfDaemonIsStopped+import Tricorder.API.OutputFormat qualified as OutputFormat+import Tricorder.API.TestFilter qualified as TestFilter+import Tricorder.API.WaitMode qualified as WaitMode+++data Command+ = Suites SuitesOptions+++data SuitesOptions = SuitesOptions+ { suiteNames :: [SuiteName]+ -- ^ Test suites to show. Empty means all of them.+ , testFilter :: TestFilter+ , fields :: Maybe FieldMask+ -- ^ Fields to show for each test suite. 'Nothing' uses the default fields.+ , format :: OutputFormat+ , wait :: WaitMode+ , ifDaemonIsStopped :: IfDaemonIsStopped+ }+++type SuiteName = Text+++toArgs :: Command -> [String]+toArgs = \case+ Suites (SuitesOptions {suiteNames, testFilter, fields, format, wait, ifDaemonIsStopped}) ->+ "suites"+ : fmap toString suiteNames+ <> TestFilter.toArgs testFilter+ <> FieldMask.toArgs fields+ <> OutputFormat.toArgs format+ <> WaitMode.toArgs wait+ <> IfDaemonIsStopped.toArgs ifDaemonIsStopped
+ src/Tricorder/API/Test/Args.hs view
@@ -0,0 +1,93 @@+module Tricorder.API.Test.Args (parser) where++import Options.Applicative+ ( Parser+ , ParserInfo+ , command+ , footer+ , help+ , helpDoc+ , hsubparser+ , info+ , metavar+ , progDesc+ , strArgument+ )++import Data.Text qualified as T+import Options.Applicative.Help.Pretty qualified as Doc++import Tricorder.API.Test (Command)++import Tricorder.API.FieldMask qualified as FieldMask+import Tricorder.API.FieldMask.Args qualified as FieldMask.Args+import Tricorder.API.FieldMask.Schema qualified as FieldMask (Schema (..))+import Tricorder.API.FieldMask.Schema qualified as FieldMask.Schema+import Tricorder.API.IfDaemonIsStopped.Args qualified as IfDaemonIsStopped.Args+import Tricorder.API.OutputFormat.Args qualified as OutputFormat.Args+import Tricorder.API.Test qualified as Test+import Tricorder.API.Test.SuiteView.Schema qualified as SuiteView.Schema+import Tricorder.API.TestFilter.Args qualified as TestFilter.Args+import Tricorder.API.WaitMode.Args qualified as WaitMode.Args+++parser :: ParserInfo Command+parser =+ info commandParser (progDesc "See statuses and information on configured test suites.")+++commandParser :: Parser Command+commandParser =+ hsubparser+ $ command+ "suites"+ ( info+ suitesParser+ ( progDesc "Show test suites, their test cases and output."+ <> footer suitesFooter+ )+ )+++suitesParser :: Parser Command+suitesParser =+ fmap Test.Suites+ $ Test.SuitesOptions+ <$> many (strArgument (metavar "TEST-TARGET..." <> help "Test suites to show (default: all)"))+ <*> TestFilter.Args.parser (help "Show only failed test suites, and only their failed test cases")+ <*> FieldMask.Args.parser+ ( helpDoc+ $ Just+ $ (<> Doc.line)+ $ mconcat+ $ Doc.punctuate+ (Doc.line <> Doc.line)+ [ "Comma-separated list of fields to return for each test suite."+ , "Available fields:"+ <> Doc.line+ <> Doc.indent 4 (Doc.vsep $ FieldMask.Schema.render SuiteView.Schema.schema)+ , "Select nested fields with parentheses,"+ <> Doc.line+ <> "e.g. --fields 'name,cases(description,failure)'."+ <> Doc.line+ <> "A field without parentheses shows all of its nested fields."+ , "Default fields:"+ <> Doc.line+ <> Doc.pretty (FieldMask.render SuiteView.Schema.defaultFields)+ ]+ )+ <*> OutputFormat.Args.parser+ <*> WaitMode.Args.parser+ <*> IfDaemonIsStopped.Args.parser+++suitesFooter :: String+suitesFooter =+ toString+ $ "Available fields:\n"+ <> renderSchema SuiteView.Schema.schema+ <> "\nSelect nested fields with parentheses, e.g. --fields 'name,cases(description,failure)'."+ <> " A field without parentheses shows all of its nested fields."+ where+ renderSchema (FieldMask.Schema fields) = T.intercalate ", " $ renderField <$> fields+ renderField (name, sub) = name <> maybe "" (\nestedSchema -> "(" <> renderSchema nestedSchema <> ")") sub
+ src/Tricorder/API/Test/SuiteView.hs view
@@ -0,0 +1,51 @@+module Tricorder.API.Test.SuiteView+ ( SuiteView (..)+ , Status (..)+ , CaseView (..)+ , Outcome (..)+ )+where++import Atelier.Time (AsRawUnit, Millisecond)+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Data.Aeson (ToJSON (..))+++-- | Fields that do not apply to a suite's 'Status' are 'Nothing', and are+-- left out of the output.+data SuiteView = SuiteView+ { name :: Text+ , status :: Status+ , error :: Maybe Text+ , passedCases :: Maybe Int+ , totalCases :: Maybe Int+ , durationMs :: Maybe (AsRawUnit Millisecond)+ , output :: Maybe Text+ , cases :: Maybe [CaseView]+ }+ deriving stock (Eq, Generic, Show)+ deriving (ToJSON) via QuietSnake SuiteView+++data Status = Running | Errored | Passed | Failed+ deriving stock (Eq, Generic, Show)+ deriving (ToJSON) via QuietSnake Status+++data CaseView = CaseView+ { description :: Text+ , outcome :: Outcome+ , failure :: Maybe Text+ }+ deriving stock (Eq, Generic, Show)+ deriving (ToJSON) via QuietSnake CaseView+++data Outcome = CasePassed | CaseFailed+ deriving stock (Eq, Generic, Show)+++instance ToJSON Outcome where+ toJSON = \case+ CasePassed -> "passed"+ CaseFailed -> "failed"
+ src/Tricorder/API/Test/SuiteView/Schema.hs view
@@ -0,0 +1,36 @@+module Tricorder.API.Test.SuiteView.Schema (defaultFields, schema) where++import Tricorder.API.FieldMask (FieldMask (..))++import Tricorder.API.FieldMask qualified as FieldMask+import Tricorder.API.FieldMask.Schema qualified as FieldMask (Schema (..))+import Tricorder.API.FieldMask.Schema qualified as FieldMask.Schema+++-- | Every field of a 'SuiteView', as named in its JSON encoding.+schema :: FieldMask.Schema+schema =+ FieldMask.Schema+ [ FieldMask.Schema.leaf "name"+ , FieldMask.Schema.leaf "status"+ , FieldMask.Schema.leaf "error"+ , FieldMask.Schema.leaf "passed_cases"+ , FieldMask.Schema.leaf "total_cases"+ , FieldMask.Schema.leaf "duration_ms"+ , FieldMask.Schema.leaf "output"+ , FieldMask.Schema.nested+ "cases"+ [ FieldMask.Schema.leaf "description"+ , FieldMask.Schema.leaf "outcome"+ , FieldMask.Schema.leaf "failure"+ ]+ ]+++-- | A summary of each suite, leaving out the (potentially large) test output+-- and test cases.+defaultFields :: FieldMask+defaultFields =+ FieldMask+ $ (\name -> FieldMask.Field name Nothing)+ <$> "name" :| ["status", "error", "passed_cases", "total_cases", "duration_ms"]
+ src/Tricorder/API/TestFilter.hs view
@@ -0,0 +1,26 @@+module Tricorder.API.TestFilter+ ( TestFilter (..)+ , toArgs+ , failedOnlyFlagName+ , failedOnlyFlagShortName+ )+where++import Prelude hiding (All (..))+++data TestFilter = All | FailedOnly+ deriving stock (Bounded, Enum, Eq)+++toArgs :: TestFilter -> [String]+toArgs All = []+toArgs FailedOnly = ["--" <> failedOnlyFlagName]+++failedOnlyFlagName :: String+failedOnlyFlagName = "failed-only"+++failedOnlyFlagShortName :: Char+failedOnlyFlagShortName = 'f'
+ src/Tricorder/API/TestFilter/Args.hs view
@@ -0,0 +1,19 @@+module Tricorder.API.TestFilter.Args (parser) where++import Options.Applicative (FlagFields, Mod, Parser, flag, long, short)++import Tricorder.API.TestFilter+ ( TestFilter (..)+ , failedOnlyFlagName+ , failedOnlyFlagShortName+ )++import Tricorder.API.TestFilter qualified as TestFilter+++parser :: Mod FlagFields TestFilter -> Parser TestFilter+parser extraMods =+ flag TestFilter.All TestFilter.FailedOnly+ $ long failedOnlyFlagName+ <> short failedOnlyFlagShortName+ <> extraMods
+ src/Tricorder/API/WaitMode.hs view
@@ -0,0 +1,21 @@+module Tricorder.API.WaitMode+ ( WaitMode (..)+ , toArgs+ , waitForBuildFlagName+ )+where+++data WaitMode+ = ShowCurrent+ | WaitForBuild+ deriving stock (Eq)+++toArgs :: WaitMode -> [String]+toArgs WaitForBuild = ["--" <> waitForBuildFlagName]+toArgs ShowCurrent = []+++waitForBuildFlagName :: String+waitForBuildFlagName = "wait"
+ src/Tricorder/API/WaitMode/Args.hs view
@@ -0,0 +1,13 @@+module Tricorder.API.WaitMode.Args (parser) where++import Options.Applicative (Parser, flag, help, long, short)++import Tricorder.API.WaitMode (WaitMode (..), waitForBuildFlagName)+++parser :: Parser WaitMode+parser =+ flag ShowCurrent WaitForBuild+ $ long waitForBuildFlagName+ <> short 'w'+ <> help "Block until the current build cycle completes"
− src/Tricorder/CLI/Command.hs
@@ -1,125 +0,0 @@-module Tricorder.CLI.Command- ( Command (..)- , EvalCommentsOptions (..)- , Force (..)- , LogMode (..)- , SourceOptions (..)- , StatusOptions (..)- , TestOptions (..)- , Verbosity (..)- , commandToArgs- )-where--import Tricorder.CLI.Command.Daemon (DaemonCommand)-import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))-import Tricorder.CLI.Command.WaitMode (WaitMode)-import Tricorder.SourceLookup.SourceQuery (SourceQuery, renderSourceQuery)--import Tricorder.CLI.Command.Daemon qualified as Daemon-import Tricorder.CLI.Command.OutputFormat qualified as OutputFormat-import Tricorder.CLI.Command.Test qualified as Test-import Tricorder.CLI.Command.WaitMode qualified as WaitMode---data Force = Force | NoForce---data Verbosity- = Concise- | Verbose- deriving stock (Eq)---data LogMode = ShowLog | ShowLogPath---data StatusOptions = StatusOptions- { wait :: WaitMode- , format :: OutputFormat- , verbosity :: Verbosity- , expand :: Maybe Int- }---data TestOptions = TestOptions- { failedOnly :: Bool- , wait :: WaitMode- }---data EvalCommentsOptions = EvalCommentsOptions- { wait :: WaitMode- , format :: OutputFormat- }---data SourceOptions = SourceOptions- { queries :: [SourceQuery]- , maxDepth :: Maybe Word- -- ^ Most re-export hops to follow for a symbol query; 'Nothing' is the default.- , maxModules :: Maybe Word- -- ^ Most modules to read while following re-exports; 'Nothing' is the default.- }---data Command- = Start- | Stop Force- | Status StatusOptions- | -- | DEPRECATED: Use 'Test' instead.- TestResults TestOptions- | Test Test.Command- | UI- | Log LogMode- | Source SourceOptions- | Restart Force- | EvalComments EvalCommentsOptions- | Daemon DaemonCommand----- | Render a 'Command' to the argument list the @tricorder@ CLI expects--- (subcommand name followed by flags) — the inverse of the parser in--- "Tricorder.CLI.Arguments". Kept next to 'Command' so a new field or--- constructor forces both the parser and this renderer to be updated--- together; this is what @tricorder-mcp@ uses to invoke @tricorder@ without--- duplicating flag names.-commandToArgs :: Command -> [String]-commandToArgs Start = ["start"]-commandToArgs (Stop doForce) = "stop" : forceArgs doForce-commandToArgs (Status (StatusOptions {wait, format, verbosity, expand})) =- "status"- : WaitMode.toArgs wait- <> OutputFormat.toArgs format- <> verbosityArgs verbosity- <> maybe [] (\n -> ["--expand", show n]) expand-commandToArgs (TestResults (TestOptions {failedOnly, wait})) =- "test-results" : failedArgs failedOnly <> WaitMode.toArgs wait-commandToArgs (Test testCommand) = "test" : Test.toArgs testCommand-commandToArgs UI = ["ui"]-commandToArgs (Log ShowLogPath) = ["log", "--print-path"]-commandToArgs (Log ShowLog) = ["log"]-commandToArgs (Source (SourceOptions {queries, maxDepth, maxModules})) =- "source"- : maybe [] (\n -> ["--max-depth", show n]) maxDepth- <> maybe [] (\n -> ["--max-modules", show n]) maxModules- <> map renderSourceQuery queries-commandToArgs (Restart doForce) = "restart" : forceArgs doForce-commandToArgs (EvalComments (EvalCommentsOptions {wait, format})) =- "eval-comments" : WaitMode.toArgs wait <> OutputFormat.toArgs format-commandToArgs (Daemon daemonCommand) = "daemon" : Daemon.toArgs daemonCommand---forceArgs :: Force -> [String]-forceArgs Force = ["--force"]-forceArgs NoForce = []---verbosityArgs :: Verbosity -> [String]-verbosityArgs Verbose = ["--verbose"]-verbosityArgs Concise = []---failedArgs :: Bool -> [String]-failedArgs True = ["--failed"]-failedArgs False = []
− src/Tricorder/CLI/Command/Daemon.hs
@@ -1,14 +0,0 @@-module Tricorder.CLI.Command.Daemon (DaemonCommand (..), toArgs) where--import Tricorder.CLI.Command.OutputFormat (OutputFormat)--import Tricorder.CLI.Command.OutputFormat qualified as OutputFormat---data DaemonCommand- = Info OutputFormat---toArgs :: DaemonCommand -> [String]-toArgs = \case- Info format -> "info" : OutputFormat.toArgs format
− src/Tricorder/CLI/Command/IfDaemonIsStopped.hs
@@ -1,21 +0,0 @@-module Tricorder.CLI.Command.IfDaemonIsStopped- ( IfDaemonIsStopped (..)- , toArgs- , startDaemonFlagName- )-where---data IfDaemonIsStopped- = StartDaemon- | Fail---toArgs :: IfDaemonIsStopped -> [String]-toArgs = \case- StartDaemon -> ["--" <> startDaemonFlagName]- Fail -> []---startDaemonFlagName :: String-startDaemonFlagName = "start-daemon"
− src/Tricorder/CLI/Command/OutputFormat.hs
@@ -1,21 +0,0 @@-module Tricorder.CLI.Command.OutputFormat- ( OutputFormat (..)- , toArgs- , jsonOutputFlagName- )-where---data OutputFormat- = TextOutput- | JsonOutput- deriving stock (Eq, Show)---toArgs :: OutputFormat -> [String]-toArgs JsonOutput = ["--" <> jsonOutputFlagName]-toArgs TextOutput = []---jsonOutputFlagName :: String-jsonOutputFlagName = "json"
− src/Tricorder/CLI/Command/Test.hs
@@ -1,52 +0,0 @@-module Tricorder.CLI.Command.Test- ( Command (..)- , SuitesOptions (..)- , SuiteName- , toArgs- )-where--import Prelude hiding (All, filter)--import Tricorder.CLI.Command.IfDaemonIsStopped (IfDaemonIsStopped)-import Tricorder.CLI.Command.OutputFormat (OutputFormat)-import Tricorder.CLI.Command.TestFilter (TestFilter)-import Tricorder.CLI.Command.WaitMode (WaitMode)-import Tricorder.FieldMask (FieldMask)--import Tricorder.CLI.Command.IfDaemonIsStopped qualified as IfDaemonIsStopped-import Tricorder.CLI.Command.OutputFormat qualified as OutputFormat-import Tricorder.CLI.Command.TestFilter qualified as TestFilter-import Tricorder.CLI.Command.WaitMode qualified as WaitMode-import Tricorder.FieldMask qualified as FieldMask---data Command- = Suites SuitesOptions---data SuitesOptions = SuitesOptions- { suiteNames :: [SuiteName]- -- ^ Test suites to show. Empty means all of them.- , testFilter :: TestFilter- , fields :: Maybe FieldMask- -- ^ Fields to show for each test suite. 'Nothing' uses the default fields.- , format :: OutputFormat- , wait :: WaitMode- , ifDaemonIsStopped :: IfDaemonIsStopped- }---type SuiteName = Text---toArgs :: Command -> [String]-toArgs = \case- Suites (SuitesOptions {suiteNames, testFilter, fields, format, wait, ifDaemonIsStopped}) ->- "suites"- : fmap toString suiteNames- <> TestFilter.toArgs testFilter- <> FieldMask.toArgs fields- <> OutputFormat.toArgs format- <> WaitMode.toArgs wait- <> IfDaemonIsStopped.toArgs ifDaemonIsStopped
− src/Tricorder/CLI/Command/TestFilter.hs
@@ -1,25 +0,0 @@-module Tricorder.CLI.Command.TestFilter- ( TestFilter (..)- , toArgs- , failedOnlyFlagName- , failedOnlyFlagShortName- )-where--import Prelude hiding (All (..))---data TestFilter = All | FailedOnly---toArgs :: TestFilter -> [String]-toArgs All = []-toArgs FailedOnly = ["--" <> failedOnlyFlagName]---failedOnlyFlagName :: String-failedOnlyFlagName = "failed-only"---failedOnlyFlagShortName :: Char-failedOnlyFlagShortName = 'f'
− src/Tricorder/CLI/Command/WaitMode.hs
@@ -1,21 +0,0 @@-module Tricorder.CLI.Command.WaitMode- ( WaitMode (..)- , toArgs- , waitForBuildFlagName- )-where---data WaitMode- = ShowCurrent- | WaitForBuild- deriving stock (Eq)---toArgs :: WaitMode -> [String]-toArgs WaitForBuild = ["--" <> waitForBuildFlagName]-toArgs ShowCurrent = []---waitForBuildFlagName :: String-waitForBuildFlagName = "wait"
− src/Tricorder/FieldMask.hs
@@ -1,42 +0,0 @@-module Tricorder.FieldMask- ( FieldMask (..)- , Field (..)- , render- , toArgs- , fieldsFlagName- )-where--import Data.Text qualified as T----- | A selection of fields to include in a response, in the style of Google's--- partial-response @fields@ parameter:------ @--- name,status,cases(description,failure)--- @-newtype FieldMask = FieldMask {getFields :: NonEmpty Field}- deriving stock (Eq, Show)---data Field = Field- { name :: Text- , subFields :: Maybe FieldMask- -- ^ 'Nothing' selects the field's whole value.- }- deriving stock (Eq, Show)---render :: FieldMask -> Text-render (FieldMask fields) = T.intercalate "," $ renderField <$> toList fields- where- renderField field = field.name <> maybe "" (\sub -> "(" <> render sub <> ")") field.subFields---toArgs :: Maybe FieldMask -> [String]-toArgs = maybe [] \mask -> ["--" <> fieldsFlagName, toString $ render mask]---fieldsFlagName :: String-fieldsFlagName = "fields"
− src/Tricorder/FieldMask/Args.hs
@@ -1,41 +0,0 @@-module Tricorder.FieldMask.Args (parser, parse) where--import Options.Applicative (Mod, OptionFields, Parser, eitherReader, long, metavar, option)-import Text.Megaparsec (Parsec, between, eof, errorBundlePretty, takeWhile1P)-import Text.Megaparsec.Char (space)--import Data.Char qualified as Char-import Text.Megaparsec qualified as Megaparsec-import Text.Megaparsec.Char.Lexer qualified as Lexer--import Tricorder.FieldMask (Field (..), FieldMask (..), fieldsFlagName)---parser :: Mod OptionFields FieldMask -> Parser (Maybe FieldMask)-parser extraMods =- optional- $ option (eitherReader $ first toString . parse . toText)- $ long fieldsFlagName- <> metavar "FIELDS"- <> extraMods----- | Parse a field mask such as @name,status,cases(description,failure)@.-parse :: Text -> Either Text FieldMask-parse =- first (toText . errorBundlePretty)- . Megaparsec.parse (space *> fieldMask <* eof) "fields"- where- fieldMask :: TParser FieldMask- fieldMask = FieldMask <$> ((:|) <$> field <*> many (symbol "," *> field))-- field :: TParser Field- field = Field <$> lexeme fieldName <*> optional (between (symbol "(") (symbol ")") fieldMask)-- fieldName = takeWhile1P (Just "field name") \c -> Char.isAlphaNum c || c == '_'-- lexeme = Lexer.lexeme space- symbol = Lexer.symbol space---type TParser = Parsec Void Text
− src/Tricorder/FieldMask/Projection.hs
@@ -1,68 +0,0 @@--- | Parsing field masks, checking them against the shape of a response, and--- projecting response values down to the selected fields.-module Tricorder.FieldMask.Projection- ( Projection (..)- , project- , renderYaml- )-where--import Data.Aeson (ToJSON (..), Value (..), object, pairs, (.=))--import Data.Aeson.Key qualified as Key-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Yaml.Builder qualified as Yaml--import Tricorder.FieldMask.Schema (Schema (..))----- | A JSON value cut down to the fields of a 'Schema', with its fields in--- schema order.-data Projection- = PObject [(Text, Projection)]- | PArray [Projection]- | PScalar Value- deriving stock (Eq, Show)---instance ToJSON Projection where- toJSON = \case- PObject fields -> object [Key.fromText name .= value | (name, value) <- fields]- PArray values -> toJSON values- PScalar value -> value- toEncoding = \case- PObject fields -> pairs $ foldMap (\(name, value) -> Key.fromText name .= value) fields- PArray values -> toEncoding values- PScalar value -> toEncoding value----- | Keep only the fields in the 'Schema'. Arrays are projected element-wise,--- and fields that are missing or @null@ are left out.-project :: Schema -> Value -> Projection-project schema@(Schema fields) = \case- Array values -> PArray $ project schema <$> toList values- Object obj ->- PObject- [ (name, maybe PScalar project sub value)- | (name, sub) <- fields- , Just value <- [KeyMap.lookup (Key.fromText name) obj]- , value /= Null- ]- value -> PScalar value---renderYaml :: Projection -> Text-renderYaml = decodeUtf8 . Yaml.toByteString . toYaml- where- toYaml = \case- PObject fields -> Yaml.mapping $ second toYaml <$> fields- PArray values -> Yaml.array $ toYaml <$> values- PScalar value -> valueToYaml value-- valueToYaml = \case- Object obj -> Yaml.mapping $ bimap Key.toText valueToYaml <$> KeyMap.toList obj- Array values -> Yaml.array $ valueToYaml <$> toList values- String text -> Yaml.string text- Number number -> Yaml.scientific number- Bool b -> Yaml.bool b- Null -> Yaml.null
− src/Tricorder/FieldMask/Schema.hs
@@ -1,53 +0,0 @@-module Tricorder.FieldMask.Schema- ( Schema (..)- , leaf- , nested- , select- )-where--import Data.List qualified as List-import Data.Text qualified as T--import Tricorder.FieldMask (Field (..), FieldMask (..))----- | The fields available in a response, in the order they are shown by--- default. Fields without a nested 'Schema' are shown as-is.------ A 'Schema' narrowed down by 'select' describes exactly what to show.-newtype Schema = Schema [(Text, Maybe Schema)]- deriving stock (Eq, Show)---leaf :: Text -> (Text, Maybe Schema)-leaf name = (name, Nothing)---nested :: Text -> [(Text, Maybe Schema)] -> (Text, Maybe Schema)-nested name fields = (name, Just $ Schema fields)----- | Narrow a 'Schema' down to the fields of a 'FieldMask', keeping the order--- the fields were requested in. Fails on fields the schema does not have.-select :: Schema -> FieldMask -> Either Text Schema-select = go []- where- go path (Schema available) (FieldMask requested) =- Schema <$> traverse (selectField path available) (toList requested)-- selectField path available field =- case (field.subFields, List.lookup field.name available) of- (_, Nothing) ->- Left- $ "unknown field "- <> quote (fieldPath path field.name)- <> ", expected one of: "- <> T.intercalate ", " (fst <$> available)- (Nothing, Just schema) -> Right (field.name, schema)- (Just mask, Just (Just schema)) -> (field.name,) . Just <$> go (field.name : path) schema mask- (Just _, Just Nothing) ->- Left $ "field " <> quote (fieldPath path field.name) <> " has no sub-fields"-- fieldPath path name = T.intercalate "." $ reverse $ name : path- quote name = "'" <> name <> "'"
+ src/Tricorder/SourceLookup/ModuleSourceResult.hs view
@@ -0,0 +1,25 @@+module Tricorder.SourceLookup.ModuleSourceResult (ModuleSourceResult (..)) where++import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generically (..))++import Tricorder.SourceLookup.PackageId (PackageId)+import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery)+++-- | The result of a source lookup for a single module.+data ModuleSourceResult+ = -- | Source was found; contains the module (or single-symbol) source text.+ SourceFound SourceQuery Text+ | -- | The module is neither in the project nor in any installed package.+ SourceNotFound SourceQuery+ | -- | The package was resolved but no source tarball could be located or+ -- fetched (no index, offline, yanked, or the archive could not be read).+ SourceUnavailable SourceQuery PackageId+ | -- | The symbol is not defined in the queried module but re-exported by+ -- it; contains the module that defines it and the symbol's source there.+ SourceReexported SourceQuery ModuleName Text+ | -- | The module source was found but the requested symbol was not in it.+ FunctionNotFound SourceQuery+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via Generically ModuleSourceResult
+ src/Tricorder/SourceLookup/PackageId.hs view
@@ -0,0 +1,25 @@+module Tricorder.SourceLookup.PackageId+ ( PackageId (..)+ , splitPackageId+ )+where++import Data.Aeson (FromJSON, ToJSON)++import Data.Text qualified as T+++-- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@.+newtype PackageId = PackageId {unPackageId :: Text}+ deriving stock (Eq, Ord, Show)+ deriving (FromJSON, Hashable, IsString, ToJSON) via Text+++-- | Split a 'PackageId' into its package name and version. The version is the+-- final hyphen-delimited component (versions are dot-, not hyphen-separated),+-- so @"list-t-1.0.5.7"@ → @("list-t", "1.0.5.7")@.+splitPackageId :: PackageId -> (Text, Text)+splitPackageId (PackageId pid) =+ case reverse (T.splitOn "-" pid) of+ (ver : nameParts@(_ : _)) -> (T.intercalate "-" (reverse nameParts), ver)+ _ -> (pid, "")
+ src/Tricorder/SourceLookup/ReexportLimits.hs view
@@ -0,0 +1,22 @@+module Tricorder.SourceLookup.ReexportLimits+ ( ReexportLimits (..)+ , defaultReexportLimits+ )+where+++-- | Bounds on the re-export search for a symbol the queried module does not+-- define itself (see 'followReexports').+data ReexportLimits = ReexportLimits+ { maxDepth :: Word+ -- ^ Most re-export hops to follow; @0@ disables following re-exports.+ , maxModules :: Word+ -- ^ Most modules to read during the search.+ }+ deriving stock (Eq, Show)+++-- | Enough for the deepest chains seen in practice (@Prelude#Maybe@ takes 3+-- hops through @ghc-internal@) while keeping a miss cheap.+defaultReexportLimits :: ReexportLimits+defaultReexportLimits = ReexportLimits {maxDepth = 5, maxModules = 24}
+ test/Unit/Tricorder/API/FieldMask/ArgsSpec.hs view
@@ -0,0 +1,55 @@+module Unit.Tricorder.API.FieldMask.ArgsSpec (test_Args) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++import Tricorder.API.FieldMask (Field (..), FieldMask (..))+import Tricorder.API.FieldMask.Args (parse)++import Tricorder.API.FieldMask qualified as FieldMask+++test_Args :: TestTree+test_Args =+ testGroup+ "Tricorder.API.FieldMask.Args"+ [ testGroup "parse" testParse+ ]+++testParse :: [TestTree]+testParse =+ [ testCase "parses a flat list of fields" do+ parse "name,status" @?= Right (mask [field "name", field "status"])+ , testCase "parses nested fields" do+ parse "name,cases(description,failure)"+ @?= Right (mask [field "name", Field "cases" $ Just $ mask [field "description", field "failure"]])+ , testCase "allows whitespace between tokens" do+ parse " name , cases ( description ) "+ @?= Right (mask [field "name", Field "cases" $ Just $ mask [field "description"]])+ , testCase "rejects an empty mask" do+ assertLeft $ parse ""+ , testCase "rejects a trailing comma" do+ assertLeft $ parse "name,"+ , testCase "rejects empty parentheses" do+ assertLeft $ parse "cases()"+ , testCase "rejects unbalanced parentheses" do+ assertLeft $ parse "cases(description"+ , testCase "round-trips through render" do+ let input = "name,cases(description,failure),output"+ (FieldMask.render <$> parse input) @?= Right input+ ]+++mask :: [Field] -> FieldMask+mask = maybe (error "mask: no fields") FieldMask . nonEmpty+++field :: Text -> Field+field name = Field name Nothing+++assertLeft :: (Show a) => Either Text a -> IO ()+assertLeft = \case+ Left _ -> pass+ Right a -> assertFailure $ "expected Left, got Right " <> show a
+ test/Unit/Tricorder/API/FieldMask/ProjectionSpec.hs view
@@ -0,0 +1,50 @@+module Unit.Tricorder.API.FieldMask.ProjectionSpec (test_Projection) where++import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.Text (encodeToLazyText)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Tricorder.API.FieldMask.Projection (Projection (..), project, renderYaml)+import Tricorder.API.FieldMask.Schema (Schema (..), leaf, nested)+++test_Projection :: TestTree+test_Projection =+ testGroup+ "Tricorder.API.FieldMask.Projection"+ [ testGroup "project" testProject+ ]+++testProject :: [TestTree]+testProject =+ [ testCase "keeps only the selected fields, in selection order" do+ project (Schema [leaf "status", leaf "name"]) suite+ @?= PObject [("status", PScalar "failed"), ("name", PScalar "suite")]+ , testCase "projects every element of an array" do+ project (Schema [nested "cases" [leaf "outcome"]]) suite+ @?= PObject+ [ ("cases", PArray [PObject [("outcome", PScalar "passed")], PObject [("outcome", PScalar "failed")]])+ ]+ , testCase "leaves out missing and null fields" do+ project (Schema [leaf "name", leaf "missing", leaf "error"]) suite+ @?= PObject [("name", PScalar "suite")]+ , testCase "encodes JSON objects in selection order" do+ encodeToLazyText (project (Schema [leaf "status", leaf "name"]) suite)+ @?= "{\"status\":\"failed\",\"name\":\"suite\"}"+ , testCase "renders YAML in selection order" do+ renderYaml (project (Schema [leaf "status", leaf "name"]) suite)+ @?= "status: failed\nname: suite\n"+ ]+ where+ suite =+ object+ [ "name" .= ("suite" :: Text)+ , "status" .= ("failed" :: Text)+ , "error" .= Null+ , "cases"+ .= [ object ["description" .= ("a" :: Text), "outcome" .= ("passed" :: Text)]+ , object ["description" .= ("b" :: Text), "outcome" .= ("failed" :: Text)]+ ]+ ]
+ test/Unit/Tricorder/API/FieldMask/SchemaSpec.hs view
@@ -0,0 +1,50 @@+module Unit.Tricorder.API.FieldMask.SchemaSpec (test_Schema) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Data.Text qualified as T++import Tricorder.API.FieldMask.Args (parse)+import Tricorder.API.FieldMask.Schema (Schema (..), leaf, nested, select)+++test_Schema :: TestTree+test_Schema =+ testGroup+ "Tricorder.API.FieldMask.Schema"+ [ testGroup "select" testSelect+ ]+++testSelect :: [TestTree]+testSelect =+ [ testCase "keeps the requested fields in the requested order" do+ select' "status,name" @?= Right (Schema [leaf "status", leaf "name"])+ , testCase "a field without sub-fields keeps its whole nested schema" do+ select' "cases" @?= Right (Schema [casesSchema])+ , testCase "narrows nested fields" do+ select' "cases(outcome)" @?= Right (Schema [nested "cases" [leaf "outcome"]])+ , testCase "rejects unknown fields" do+ assertLeftContaining "unknown field 'nope'" $ select' "name,nope"+ , testCase "names the path of unknown nested fields" do+ assertLeftContaining "unknown field 'cases.nope'" $ select' "cases(nope)"+ , testCase "rejects sub-fields of a field without any" do+ assertLeftContaining "field 'name' has no sub-fields" $ select' "name(x)"+ ]+ where+ select' input = select schema =<< parse input+++schema :: Schema+schema = Schema [leaf "name", leaf "status", casesSchema]+++casesSchema :: (Text, Maybe Schema)+casesSchema = nested "cases" [leaf "description", leaf "outcome"]+++assertLeftContaining :: (Show a) => Text -> Either Text a -> IO ()+assertLeftContaining needle = \case+ Left err -> assertBool (toString $ err <> "\ndoes not contain\n" <> needle) $ needle `T.isInfixOf` err+ Right a -> assertFailure $ "expected Left, got Right " <> show a
+ test/Unit/Tricorder/API/SuiteView/SchemaSpec.hs view
@@ -0,0 +1,60 @@+module Unit.Tricorder.API.SuiteView.SchemaSpec (test_Schema) where++import Atelier.Time (AsRawUnit (..))+import Data.Aeson (Value (..), toJSON)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap++import Tricorder.API.Test.SuiteView (CaseView (..), Outcome (..), Status (..), SuiteView (..))+import Tricorder.API.Test.SuiteView.Schema (defaultFields, schema)++import Tricorder.API.FieldMask.Schema qualified as FieldMask (Schema (..))+import Tricorder.API.FieldMask.Schema qualified as FieldMask.Schema+++test_Schema :: TestTree+test_Schema =+ testGroup+ "Tricorder.API.SuiteView.Schema"+ [ testCase "schema lists every field of the JSON encoding" do+ schemaKeys schema @?= jsonKeys (toJSON fullView)+ , testCase "default fields are in the schema" do+ void (FieldMask.Schema.select schema defaultFields) @?= Right ()+ ]+++-- | Keys of a JSON value, nested keys of arrays taken from their first element.+data Keys = Keys [(Text, Maybe Keys)]+ deriving stock (Eq, Show)+++schemaKeys :: FieldMask.Schema -> Keys+schemaKeys (FieldMask.Schema fields) = Keys $ sortOn fst $ second (fmap schemaKeys) <$> fields+++jsonKeys :: Value -> Keys+jsonKeys = \case+ Object obj -> Keys $ sortOn fst [(Key.toText key, nestedKeys value) | (key, value) <- KeyMap.toList obj]+ _ -> Keys []+ where+ nestedKeys = \case+ Array values | Just element <- viaNonEmpty head (toList values) -> Just $ jsonKeys element+ _ -> Nothing+++-- | A view with every field set, so every field shows up in its JSON.+fullView :: SuiteView+fullView =+ SuiteView+ { name = "test:suite"+ , status = Failed+ , error = Just "error"+ , passedCases = Just 0+ , totalCases = Just 1+ , durationMs = Just $ AsRawUnit 5+ , output = Just "output"+ , cases = Just [CaseView "case" CaseFailed (Just "failure")]+ }
− test/Unit/Tricorder/FieldMask/ArgsSpec.hs
@@ -1,55 +0,0 @@-module Unit.Tricorder.FieldMask.ArgsSpec (test_Args) where--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))--import Tricorder.FieldMask (Field (..), FieldMask (..))-import Tricorder.FieldMask.Args (parse)--import Tricorder.FieldMask qualified as FieldMask---test_Args :: TestTree-test_Args =- testGroup- "Tricorder.FieldMask.Args"- [ testGroup "parse" testParse- ]---testParse :: [TestTree]-testParse =- [ testCase "parses a flat list of fields" do- parse "name,status" @?= Right (mask [field "name", field "status"])- , testCase "parses nested fields" do- parse "name,cases(description,failure)"- @?= Right (mask [field "name", Field "cases" $ Just $ mask [field "description", field "failure"]])- , testCase "allows whitespace between tokens" do- parse " name , cases ( description ) "- @?= Right (mask [field "name", Field "cases" $ Just $ mask [field "description"]])- , testCase "rejects an empty mask" do- assertLeft $ parse ""- , testCase "rejects a trailing comma" do- assertLeft $ parse "name,"- , testCase "rejects empty parentheses" do- assertLeft $ parse "cases()"- , testCase "rejects unbalanced parentheses" do- assertLeft $ parse "cases(description"- , testCase "round-trips through render" do- let input = "name,cases(description,failure),output"- (FieldMask.render <$> parse input) @?= Right input- ]---mask :: [Field] -> FieldMask-mask = maybe (error "mask: no fields") FieldMask . nonEmpty---field :: Text -> Field-field name = Field name Nothing---assertLeft :: (Show a) => Either Text a -> IO ()-assertLeft = \case- Left _ -> pass- Right a -> assertFailure $ "expected Left, got Right " <> show a
− test/Unit/Tricorder/FieldMask/ProjectionSpec.hs
@@ -1,50 +0,0 @@-module Unit.Tricorder.FieldMask.ProjectionSpec (test_Projection) where--import Data.Aeson (Value (..), object, (.=))-import Data.Aeson.Text (encodeToLazyText)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))--import Tricorder.FieldMask.Projection (Projection (..), project, renderYaml)-import Tricorder.FieldMask.Schema (Schema (..), leaf, nested)---test_Projection :: TestTree-test_Projection =- testGroup- "Tricorder.FieldMask.Projection"- [ testGroup "project" testProject- ]---testProject :: [TestTree]-testProject =- [ testCase "keeps only the selected fields, in selection order" do- project (Schema [leaf "status", leaf "name"]) suite- @?= PObject [("status", PScalar "failed"), ("name", PScalar "suite")]- , testCase "projects every element of an array" do- project (Schema [nested "cases" [leaf "outcome"]]) suite- @?= PObject- [ ("cases", PArray [PObject [("outcome", PScalar "passed")], PObject [("outcome", PScalar "failed")]])- ]- , testCase "leaves out missing and null fields" do- project (Schema [leaf "name", leaf "missing", leaf "error"]) suite- @?= PObject [("name", PScalar "suite")]- , testCase "encodes JSON objects in selection order" do- encodeToLazyText (project (Schema [leaf "status", leaf "name"]) suite)- @?= "{\"status\":\"failed\",\"name\":\"suite\"}"- , testCase "renders YAML in selection order" do- renderYaml (project (Schema [leaf "status", leaf "name"]) suite)- @?= "status: failed\nname: suite\n"- ]- where- suite =- object- [ "name" .= ("suite" :: Text)- , "status" .= ("failed" :: Text)- , "error" .= Null- , "cases"- .= [ object ["description" .= ("a" :: Text), "outcome" .= ("passed" :: Text)]- , object ["description" .= ("b" :: Text), "outcome" .= ("failed" :: Text)]- ]- ]
− test/Unit/Tricorder/FieldMask/SchemaSpec.hs
@@ -1,50 +0,0 @@-module Unit.Tricorder.FieldMask.SchemaSpec (test_Schema) where--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))--import Data.Text qualified as T--import Tricorder.FieldMask.Args (parse)-import Tricorder.FieldMask.Schema (Schema (..), leaf, nested, select)---test_Schema :: TestTree-test_Schema =- testGroup- "Unit.Tricorder.FieldMask.Schema"- [ testGroup "select" testSelect- ]---testSelect :: [TestTree]-testSelect =- [ testCase "keeps the requested fields in the requested order" do- select' "status,name" @?= Right (Schema [leaf "status", leaf "name"])- , testCase "a field without sub-fields keeps its whole nested schema" do- select' "cases" @?= Right (Schema [casesSchema])- , testCase "narrows nested fields" do- select' "cases(outcome)" @?= Right (Schema [nested "cases" [leaf "outcome"]])- , testCase "rejects unknown fields" do- assertLeftContaining "unknown field 'nope'" $ select' "name,nope"- , testCase "names the path of unknown nested fields" do- assertLeftContaining "unknown field 'cases.nope'" $ select' "cases(nope)"- , testCase "rejects sub-fields of a field without any" do- assertLeftContaining "field 'name' has no sub-fields" $ select' "name(x)"- ]- where- select' input = select schema =<< parse input---schema :: Schema-schema = Schema [leaf "name", leaf "status", casesSchema]---casesSchema :: (Text, Maybe Schema)-casesSchema = nested "cases" [leaf "description", leaf "outcome"]---assertLeftContaining :: (Show a) => Text -> Either Text a -> IO ()-assertLeftContaining needle = \case- Left err -> assertBool (toString $ err <> "\ndoes not contain\n" <> needle) $ needle `T.isInfixOf` err- Right a -> assertFailure $ "expected Left, got Right " <> show a
tricorder-types.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-types-version: 0.5.0.0+version: 0.6.0.0 synopsis: Shared domain types for various Tricorder components description: Shared domain types for various Tricorder components like [Tricorder itself](https://hackage.haskell.org/package/tricorder) and@@ -34,17 +34,32 @@ library exposed-modules:- Tricorder.CLI.Command- Tricorder.CLI.Command.Daemon- Tricorder.CLI.Command.IfDaemonIsStopped- Tricorder.CLI.Command.OutputFormat- Tricorder.CLI.Command.Test- Tricorder.CLI.Command.TestFilter- Tricorder.CLI.Command.WaitMode- Tricorder.FieldMask- Tricorder.FieldMask.Args- Tricorder.FieldMask.Projection- Tricorder.FieldMask.Schema+ Tricorder.API.Args.Deprecated+ Tricorder.API.Command+ Tricorder.API.Command.Args+ Tricorder.API.Daemon.Args+ Tricorder.API.Daemon.Command+ Tricorder.API.FieldMask+ Tricorder.API.FieldMask.Args+ Tricorder.API.FieldMask.Projection+ Tricorder.API.FieldMask.Schema+ Tricorder.API.Force+ Tricorder.API.Force.Args+ Tricorder.API.IfDaemonIsStopped+ Tricorder.API.IfDaemonIsStopped.Args+ Tricorder.API.OutputFormat+ Tricorder.API.OutputFormat.Args+ Tricorder.API.Test+ Tricorder.API.Test.Args+ Tricorder.API.Test.SuiteView+ Tricorder.API.Test.SuiteView.Schema+ Tricorder.API.TestFilter+ Tricorder.API.TestFilter.Args+ Tricorder.API.WaitMode+ Tricorder.API.WaitMode.Args+ Tricorder.SourceLookup.ModuleSourceResult+ Tricorder.SourceLookup.PackageId+ Tricorder.SourceLookup.ReexportLimits Tricorder.SourceLookup.SourceQuery other-modules: Paths_tricorder_types@@ -72,8 +87,10 @@ ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations build-depends: aeson >=2.2 && <2.4+ , atelier-core ==0.8.* , atelier-prelude ==0.4.* , base >=4.18 && <4.23+ , effectful ==2.7.* , megaparsec >=9.7 && <9.9 , optparse-applicative ==0.19.* , text ==2.1.*@@ -88,9 +105,10 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules:- Unit.Tricorder.FieldMask.ArgsSpec- Unit.Tricorder.FieldMask.ProjectionSpec- Unit.Tricorder.FieldMask.SchemaSpec+ Unit.Tricorder.API.FieldMask.ArgsSpec+ Unit.Tricorder.API.FieldMask.ProjectionSpec+ Unit.Tricorder.API.FieldMask.SchemaSpec+ Unit.Tricorder.API.SuiteView.SchemaSpec Paths_tricorder_types autogen-modules: Paths_tricorder_types