packages feed

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 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