tricorder-types 0.4.2.0 → 0.5.0.0
raw patch · 16 files changed
+591/−22 lines, 16 filesdep +atelier-coredep +megaparsecdep +optparse-applicativePVP ok
version bump matches the API change (PVP)
Dependencies added: atelier-core, megaparsec, optparse-applicative, tasty, tasty-discover, tasty-hunit, tricorder-types, yaml
API changes (from Hackage documentation)
- Tricorder.CLI.Command: ShowCurrent :: WaitMode
- Tricorder.CLI.Command: WaitForBuild :: WaitMode
- Tricorder.CLI.Command: data WaitMode
- Tricorder.CLI.Command: instance GHC.Classes.Eq Tricorder.CLI.Command.WaitMode
+ Tricorder.CLI.Command: SourceOptions :: [SourceQuery] -> Maybe Word -> Maybe Word -> SourceOptions
+ Tricorder.CLI.Command: TestResults :: TestOptions -> Command
+ Tricorder.CLI.Command: [maxDepth] :: SourceOptions -> Maybe Word
+ Tricorder.CLI.Command: [maxModules] :: SourceOptions -> Maybe Word
+ Tricorder.CLI.Command: [queries] :: SourceOptions -> [SourceQuery]
+ Tricorder.CLI.Command: data SourceOptions
+ Tricorder.CLI.Command.IfDaemonIsStopped: Fail :: IfDaemonIsStopped
+ Tricorder.CLI.Command.IfDaemonIsStopped: StartDaemon :: IfDaemonIsStopped
+ Tricorder.CLI.Command.IfDaemonIsStopped: data IfDaemonIsStopped
+ Tricorder.CLI.Command.IfDaemonIsStopped: startDaemonFlagName :: String
+ Tricorder.CLI.Command.IfDaemonIsStopped: toArgs :: IfDaemonIsStopped -> [String]
+ Tricorder.CLI.Command.OutputFormat: instance GHC.Show.Show Tricorder.CLI.Command.OutputFormat.OutputFormat
+ Tricorder.CLI.Command.OutputFormat: jsonOutputFlagName :: String
+ Tricorder.CLI.Command.Test: Suites :: SuitesOptions -> Command
+ Tricorder.CLI.Command.Test: SuitesOptions :: [SuiteName] -> TestFilter -> Maybe FieldMask -> OutputFormat -> WaitMode -> IfDaemonIsStopped -> SuitesOptions
+ Tricorder.CLI.Command.Test: [fields] :: SuitesOptions -> Maybe FieldMask
+ Tricorder.CLI.Command.Test: [format] :: SuitesOptions -> OutputFormat
+ Tricorder.CLI.Command.Test: [ifDaemonIsStopped] :: SuitesOptions -> IfDaemonIsStopped
+ Tricorder.CLI.Command.Test: [suiteNames] :: SuitesOptions -> [SuiteName]
+ Tricorder.CLI.Command.Test: [testFilter] :: SuitesOptions -> TestFilter
+ Tricorder.CLI.Command.Test: [wait] :: SuitesOptions -> WaitMode
+ Tricorder.CLI.Command.Test: data Command
+ Tricorder.CLI.Command.Test: data SuitesOptions
+ Tricorder.CLI.Command.Test: toArgs :: Command -> [String]
+ Tricorder.CLI.Command.Test: type SuiteName = Text
+ Tricorder.CLI.Command.TestFilter: All :: TestFilter
+ Tricorder.CLI.Command.TestFilter: FailedOnly :: TestFilter
+ Tricorder.CLI.Command.TestFilter: data TestFilter
+ Tricorder.CLI.Command.TestFilter: failedOnlyFlagName :: String
+ Tricorder.CLI.Command.TestFilter: failedOnlyFlagShortName :: Char
+ Tricorder.CLI.Command.TestFilter: toArgs :: TestFilter -> [String]
+ Tricorder.CLI.Command.WaitMode: ShowCurrent :: WaitMode
+ Tricorder.CLI.Command.WaitMode: WaitForBuild :: WaitMode
+ Tricorder.CLI.Command.WaitMode: data WaitMode
+ Tricorder.CLI.Command.WaitMode: instance GHC.Classes.Eq Tricorder.CLI.Command.WaitMode.WaitMode
+ Tricorder.CLI.Command.WaitMode: toArgs :: WaitMode -> [String]
+ Tricorder.CLI.Command.WaitMode: waitForBuildFlagName :: String
+ Tricorder.FieldMask: Field :: Text -> Maybe FieldMask -> Field
+ Tricorder.FieldMask: FieldMask :: NonEmpty Field -> FieldMask
+ Tricorder.FieldMask: [getFields] :: FieldMask -> NonEmpty Field
+ Tricorder.FieldMask: [name] :: Field -> Text
+ Tricorder.FieldMask: [subFields] :: Field -> Maybe FieldMask
+ Tricorder.FieldMask: data Field
+ Tricorder.FieldMask: fieldsFlagName :: String
+ Tricorder.FieldMask: instance GHC.Classes.Eq Tricorder.FieldMask.Field
+ Tricorder.FieldMask: instance GHC.Classes.Eq Tricorder.FieldMask.FieldMask
+ Tricorder.FieldMask: instance GHC.Show.Show Tricorder.FieldMask.Field
+ Tricorder.FieldMask: instance GHC.Show.Show Tricorder.FieldMask.FieldMask
+ Tricorder.FieldMask: newtype FieldMask
+ Tricorder.FieldMask: render :: FieldMask -> Text
+ Tricorder.FieldMask: toArgs :: Maybe FieldMask -> [String]
+ Tricorder.FieldMask.Args: parse :: Text -> Either Text FieldMask
+ Tricorder.FieldMask.Args: parser :: Mod OptionFields FieldMask -> Parser (Maybe FieldMask)
+ Tricorder.FieldMask.Projection: PArray :: [Projection] -> Projection
+ Tricorder.FieldMask.Projection: PObject :: [(Text, Projection)] -> Projection
+ Tricorder.FieldMask.Projection: PScalar :: Value -> Projection
+ Tricorder.FieldMask.Projection: data Projection
+ Tricorder.FieldMask.Projection: instance Data.Aeson.Types.ToJSON.ToJSON Tricorder.FieldMask.Projection.Projection
+ Tricorder.FieldMask.Projection: instance GHC.Classes.Eq Tricorder.FieldMask.Projection.Projection
+ Tricorder.FieldMask.Projection: instance GHC.Show.Show Tricorder.FieldMask.Projection.Projection
+ Tricorder.FieldMask.Projection: project :: Schema -> Value -> Projection
+ Tricorder.FieldMask.Projection: renderYaml :: Projection -> Text
+ Tricorder.FieldMask.Schema: Schema :: [(Text, Maybe Schema)] -> Schema
+ Tricorder.FieldMask.Schema: instance GHC.Classes.Eq Tricorder.FieldMask.Schema.Schema
+ Tricorder.FieldMask.Schema: instance GHC.Show.Show Tricorder.FieldMask.Schema.Schema
+ Tricorder.FieldMask.Schema: leaf :: Text -> (Text, Maybe Schema)
+ Tricorder.FieldMask.Schema: nested :: Text -> [(Text, Maybe Schema)] -> (Text, Maybe Schema)
+ Tricorder.FieldMask.Schema: newtype Schema
+ Tricorder.FieldMask.Schema: select :: Schema -> FieldMask -> Either Text Schema
- Tricorder.CLI.Command: Source :: [SourceQuery] -> Command
+ Tricorder.CLI.Command: Source :: SourceOptions -> Command
- Tricorder.CLI.Command: Test :: TestOptions -> Command
+ Tricorder.CLI.Command: Test :: Command -> Command
Files
- CHANGELOG.md +17/−0
- src/Tricorder/CLI/Command.hs +27/−19
- src/Tricorder/CLI/Command/IfDaemonIsStopped.hs +21/−0
- src/Tricorder/CLI/Command/OutputFormat.hs +7/−2
- src/Tricorder/CLI/Command/Test.hs +52/−0
- src/Tricorder/CLI/Command/TestFilter.hs +25/−0
- src/Tricorder/CLI/Command/WaitMode.hs +21/−0
- src/Tricorder/FieldMask.hs +42/−0
- src/Tricorder/FieldMask/Args.hs +41/−0
- src/Tricorder/FieldMask/Projection.hs +68/−0
- src/Tricorder/FieldMask/Schema.hs +53/−0
- test/Driver.hs +2/−0
- test/Unit/Tricorder/FieldMask/ArgsSpec.hs +55/−0
- test/Unit/Tricorder/FieldMask/ProjectionSpec.hs +50/−0
- test/Unit/Tricorder/FieldMask/SchemaSpec.hs +50/−0
- tricorder-types.cabal +60/−1
CHANGELOG.md view
@@ -7,6 +7,23 @@ ## [Unreleased] +## [0.5.0.0] - 2026-10-20++### Added++- `Command`'s `Test` constructor for the `tricorder test` subcommand, with+ `Tricorder.CLI.Command.FieldMask` for selecting fields of the response.+ Non-breaking.+- Move all `FieldMask` modules and functionality to one place here in+ `tricorder-types` instead of having them spread out between `tricorder` and+ `tricorder-types`.++### Changed++- **Breaking:** `Command`'s `Source` constructor now takes a `SourceOptions`+ record (`queries`, `maxDepth`, `maxModules`) instead of `[SourceQuery]`.+ `commandToArgs` renders the limits as `--max-depth` / `--max-modules`.+ ## [0.4.2.0] - 2026-10-02 ### Added
src/Tricorder/CLI/Command.hs view
@@ -3,31 +3,28 @@ , EvalCommentsOptions (..) , Force (..) , LogMode (..)+ , SourceOptions (..) , StatusOptions (..) , TestOptions (..) , Verbosity (..)- , WaitMode (..) , 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 WaitMode- = ShowCurrent- | WaitForBuild- deriving stock (Eq)-- data Verbosity = Concise | Verbose@@ -57,14 +54,25 @@ } +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- | Test TestOptions+ | -- | DEPRECATED: Use 'Test' instead.+ TestResults TestOptions+ | Test Test.Command | UI | Log LogMode- | Source [SourceQuery]+ | Source SourceOptions | Restart Force | EvalComments EvalCommentsOptions | Daemon DaemonCommand@@ -81,30 +89,30 @@ commandToArgs (Stop doForce) = "stop" : forceArgs doForce commandToArgs (Status (StatusOptions {wait, format, verbosity, expand})) = "status"- : waitArgs wait+ : WaitMode.toArgs wait <> OutputFormat.toArgs format <> verbosityArgs verbosity <> maybe [] (\n -> ["--expand", show n]) expand-commandToArgs (Test (TestOptions {failedOnly, wait})) =- "test-results" : failedArgs failedOnly <> waitArgs wait+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 queries) = "source" : map renderSourceQuery queries+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" : waitArgs wait <> OutputFormat.toArgs format+ "eval-comments" : WaitMode.toArgs wait <> OutputFormat.toArgs format commandToArgs (Daemon daemonCommand) = "daemon" : Daemon.toArgs daemonCommand forceArgs :: Force -> [String] forceArgs Force = ["--force"] forceArgs NoForce = []---waitArgs :: WaitMode -> [String]-waitArgs WaitForBuild = ["--wait"]-waitArgs ShowCurrent = [] verbosityArgs :: Verbosity -> [String]
+ src/Tricorder/CLI/Command/IfDaemonIsStopped.hs view
@@ -0,0 +1,21 @@+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 view
@@ -1,6 +1,7 @@ module Tricorder.CLI.Command.OutputFormat ( OutputFormat (..) , toArgs+ , jsonOutputFlagName ) where @@ -8,9 +9,13 @@ data OutputFormat = TextOutput | JsonOutput- deriving stock (Eq)+ deriving stock (Eq, Show) toArgs :: OutputFormat -> [String]-toArgs JsonOutput = ["--json"]+toArgs JsonOutput = ["--" <> jsonOutputFlagName] toArgs TextOutput = []+++jsonOutputFlagName :: String+jsonOutputFlagName = "json"
+ src/Tricorder/CLI/Command/Test.hs view
@@ -0,0 +1,52 @@+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 view
@@ -0,0 +1,25 @@+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 view
@@ -0,0 +1,21 @@+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 view
@@ -0,0 +1,42 @@+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 view
@@ -0,0 +1,41 @@+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 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.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 view
@@ -0,0 +1,53 @@+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 <> "'"
+ test/Driver.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}+
+ test/Unit/Tricorder/FieldMask/ArgsSpec.hs view
@@ -0,0 +1,55 @@+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 view
@@ -0,0 +1,50 @@+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 view
@@ -0,0 +1,50 @@+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.4.2.0+version: 0.5.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@@ -36,7 +36,15 @@ 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.SourceLookup.SourceQuery other-modules: Paths_tricorder_types@@ -66,7 +74,58 @@ aeson >=2.2 && <2.4 , atelier-prelude ==0.4.* , base >=4.18 && <4.23+ , megaparsec >=9.7 && <9.9+ , optparse-applicative ==0.19.* , text ==2.1.*+ , yaml ==0.11.*+ mixins:+ base hiding (Prelude)+ default-language: GHC2021+ if impl(GHC >= 9.8)+ ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations++test-suite tricorder-types-test+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ Unit.Tricorder.FieldMask.ArgsSpec+ Unit.Tricorder.FieldMask.ProjectionSpec+ Unit.Tricorder.FieldMask.SchemaSpec+ Paths_tricorder_types+ autogen-modules:+ Paths_tricorder_types+ hs-source-dirs:+ test+ default-extensions:+ BlockArguments+ DataKinds+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ LambdaCase+ MultiWayIf+ OverloadedLabels+ OverloadedRecordDot+ OverloadedStrings+ StrictData+ TemplateHaskell+ TypeFamilies+ 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 -Wno-prepositive-qualified-module+ build-tool-depends:+ tasty-discover:tasty-discover+ build-depends:+ aeson >=2.2 && <2.4+ , atelier-core ==0.8.*+ , atelier-prelude ==0.4.*+ , base >=4.18 && <4.23+ , tasty ==1.5.*+ , tasty-discover ==5.2.*+ , tasty-hunit >=0.10.2 && <0.11+ , text ==2.1.*+ , tricorder-types mixins: base hiding (Prelude) default-language: GHC2021