diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,40 @@ # Changelog for agentic +## 0.2.1.0 - 2026-11-06 + +* `Contract` now produces a typed `Structure`, shared by generic derivation + and handwritten builders. `outline` exposes nominal/applied identities, + constructor/field order and style, and extensible scalar parameters. +* `compileModel` and open typed `compileWith` produce fallible codecs. Scalar + definitions can supply model defaults; independent adapters can override both + scalar and structural representations, including upstream types. +* Flow interpretation preflights all contracts and tool bodies before effects + or provider calls. Unsupported projections raise structured + `UnsupportedContract [Note] ProjectionError` failures; + discovery remains usable. Lossy nested model optionals are rejected. +* Structural mappings use `mapStructure`; compiled mappings retain `mapCodec`. + Replace `deriving via Enumeration T` with `contract = enumeration` in an + explicit `Contract T` instance. Flow descriptions now carry `Outline`. + Direct codec consumers must call `compileModel` (or another interpreter) + before accessing `.schema`, `.encode`, or `.decode`. `reschema` modifies + compiled codecs; `documented`, `field`, and `checked` modify contract trees. + Generic traversal helpers now produce typed trees, cases and fields rather + than compiled codecs. Handwritten nominal contracts can use + `nominal`; generic derivation preserves their identity automatically. +* Expose compiled builders in `Agentic.Codec` and reusable + `compileFieldsWith`/`compileCaseWith` helpers. Sum cases use existential payloads + with total matching; singleton constructors retain product structure. +* Retire MicroHs support in favor of GHC generics and type evidence. Keep the + handwritten-contract workflow suite on GHC. +* Add independent-projection acceptance fixtures under `agentic/test`, covering + exact values, malformed scalars, nested containers and preflight failures. +* `Outline` omits representation-only mappings. `OutlineField`, `OutlineCase` + and existential `Case` expose named record fields. Applicative fields use + `Pure`, `Apply` and `Field`; compiled sum cases are `CaseCodec`. +* `field` applies its annotation immediately and reports an absent field at + first evaluation. Codec-level annotation/check builders are no longer public. +* Share the test-fixture `modelContract` helper through `Agentic.Scripted`. + ## 0.2.0.5 - 2026-10-06 * `takeFirst` and `takeSecond` do what `arr fst` and `arr snd` do, but a diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -21,7 +21,7 @@ | Package | What it's for | |---|---| -| `agentic` | flows, contracts, questions, the runtime and the interpreter (depends only on `base` and `text`, and builds with MicroHs too) | +| `agentic` | flows, contracts, questions, the runtime and the interpreter (depends only on `base` and `text`; GHC 9.6+) | | `agentic-jev` | Jev as System One | | `agentic-anthropic` | Claude as System Two (or System One) | | `agentic-openai` | OpenAI as System Two (or System One) | @@ -64,8 +64,8 @@ Wrap :: (i -> o) -> Step m i o -- Left, Right Arr :: (i -> o) -> Step m i o Act :: (i -> m o) -> Step m i o - Draft :: Codec i -> Codec o -> Instruction -> [Tool m] -> Step m i o - Judge :: Codec i -> Questions o -> Step m i o + Draft :: Structure i -> Structure o -> Instruction -> [Tool m] -> Step m i o + Judge :: Structure i -> Questions o -> Step m i o data Agentic m i o where Step :: Step m i o -> Agentic m i o @@ -159,6 +159,30 @@ And describe an enumeration once - Claude and Jev both see the same wording (see `Options` below). +### One contract, several representations + +A contract is a typed description of the structure. The model codec is one +interpretation of it; a storage adapter can choose another, with its own +encoding and validation. You still derive `Contract` once. + +Normal `draft`, `judge`, and `tool` calls handle compilation for you. When you +want a codec directly: + +```haskell +case compileModel (contract @Joke) of + Left problem -> print problem + Right codec -> print (codec.encode joke) +``` + +Custom scalars keep their identity inside records and containers. They can +supply a default model codec, and another library can supply a different +projection without changing their definition. `outline` exposes the +structure even when no model representation is available. + +`interpret` checks the whole flow before running effects, including unused +branches and tool results. Unsupported model projections fail there. The core +now requires GHC; MicroHs support has been retired. + ## Is it actually funny? An LLM is great at writing. Jev is great at judging - quickly, and with a @@ -192,7 +216,7 @@ , option Solid "An audible groan from most of the room" , option Unbearable "People get up and leave" ] -deriving via Enumeration Groan instance Contract Groan +instance Contract Groan where contract = enumeration groan :: Questions (Score Groan) groan = score "How much will the audience groan?" diff --git a/agentic.cabal b/agentic.cabal --- a/agentic.cabal +++ b/agentic.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: agentic -version: 0.2.0.5 +version: 0.2.1.0 synopsis: Composable, inspectable agentic workflows mixing LLMs and Jev description: Typed agentic workflows built from Arrow combinators. A flow is a description: you can describe it as a tree, Mermaid or Graphviz before running anything, then interpret it against System One (Jev) and System Two (an LLM) providers. This is the core: flows, contracts, questions, the runtime and the interpreter. It depends only on base and text. @@ -45,6 +45,7 @@ exposed-modules: Agentic Agentic.Contract + Agentic.Codec Agentic.Core Agentic.Describe Agentic.Interpret @@ -65,12 +66,11 @@ hs-source-dirs: test main-is: Spec.hs build-depends: - , agentic ==0.2.* + , agentic >=0.2.1 && <0.3 , base >=4.18 && <5 , hspec >=2.10 && <3 , text >=2.0 && <2.2 --- The core without GHC-only features, in a pure monad. CI also runs this same --- file under MicroHs. +-- Handwritten contracts and interpreter behavior in a pure monad. test-suite agentic-portable-test import: shared type: exitcode-stdio-1.0 @@ -80,3 +80,16 @@ , agentic , base , text + +-- Independent projection adapters and acceptance fixtures. +test-suite agentic-projection-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: ProjectionSpec.hs + other-modules: ProjectionExample + build-depends: + , agentic >=0.2.1 && <0.3 + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 diff --git a/src/Agentic.hs b/src/Agentic.hs --- a/src/Agentic.hs +++ b/src/Agentic.hs @@ -19,15 +19,16 @@ , module Agentic.Settings ) where -import Agentic.Contract +import Agentic.Contract (Case, Structure, Fields) +import Agentic.Contract hiding (Case (..), Structure (..), Fields (..)) import Agentic.Core import Agentic.Describe import Agentic.Interpret import Agentic.Questions -import Agentic.Runtime hiding (Conversation (..)) import Agentic.Runtime (Conversation) -import Agentic.Schema hiding (Field (..), Format (..), Schema (..), Shape (..), Variant (..)) +import Agentic.Runtime hiding (Conversation (..)) import Agentic.Schema (Field, Format, Schema, Shape, Variant) +import Agentic.Schema hiding (Field (..), Format (..), Schema (..), Shape (..), Variant (..)) import Agentic.Settings import Agentic.Value import Agentic.ViaLLM diff --git a/src/Agentic/Codec.hs b/src/Agentic/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/Codec.hs @@ -0,0 +1,149 @@ +-- | Compiled codecs and builders for projection interpreters. Structural contracts live in +-- "Agentic.Contract"; this module contains no contract instances. +module Agentic.Codec + ( Codec (..) + , mapCodec + , reschema + , primitive + , mismatch + , ObjectCodec (..) + , record + , requiredWith + , lmapObject + , CaseCodec (..) + , sumOf + ) where + +import Agentic.Schema +import Agentic.Value +import Data.List (find) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as T + +-- | A compiled schema with a matching typed encoder and validating decoder. +data Codec a = Codec + { schema :: Schema + , encode :: a -> Value + , decode :: Value -> Either Text a + } + +-- | Change the Haskell value type using inverse mappings, retaining the schema. +mapCodec :: (a -> b) -> (b -> a) -> Codec a -> Codec b +mapCodec to' from' c = Codec c.schema (c.encode . from') (fmap to' . c.decode) + +-- | Change a codec's schema. (A record update can't do this: t'Field' has a +-- @schema@ too, so @c {schema = ...}@ is ambiguous.) +reschema :: (Schema -> Schema) -> Codec a -> Codec a +reschema f (Codec s e d) = Codec (f s) e d + +-- | Build a leaf codec from its projected shape and typed conversion functions. +primitive :: Shape -> (a -> Value) -> (Value -> Either Text a) -> Codec a +primitive s = Codec (schemaOf s) + +-- | Report an unexpected value with its expected shape and JSON rendering. +mismatch :: Text -> Value -> Either Text a +mismatch expected v = Left ("expected " <> expected <> ", got " <> renderJson v) + +-- | Compiled fields: encode an input object and applicatively reconstruct an +-- output object. Field order is retained for schemas and encoded values. +data ObjectCodec i o = ObjectCodec + { fields :: [Field] + , encode :: i -> [(Text, Value)] + , decode :: [(Text, Value)] -> Either Text o + } + +instance Functor (ObjectCodec i) where + fmap f (ObjectCodec fs e d) = ObjectCodec fs e (fmap f . d) + +instance Applicative (ObjectCodec i) where + pure x = ObjectCodec [] (const []) (const (Right x)) + f <*> x = + ObjectCodec + (f.fields <> x.fields) + (\i -> f.encode i <> x.encode i) + (\kvs -> f.decode kvs <*> x.decode kvs) + +-- | Adapt the input supplied to a compiled object's field getters. +lmapObject :: (j -> i) -> ObjectCodec i o -> ObjectCodec j o +lmapObject g (ObjectCodec fs e d) = ObjectCodec fs (e . g) d + +-- | A field with an explicit codec. Nullable fields ('Maybe') may be absent. +requiredWith :: Text -> Maybe Text -> Codec a -> (r -> a) -> ObjectCodec r a +requiredWith name d c get = + ObjectCodec + [Field name schema (not nullable)] + (\r -> [(name, c.encode (get r))]) + ( \kvs -> case lookupField name kvs of + Just v -> prefix (c.decode v) + Nothing + | nullable -> prefix (c.decode Null) + | otherwise -> Left ("missing field " <> name) + ) + where + schema = maybe id documentedSchema d c.schema + nullable = case c.schema.shape of + SNullable _ -> True + _ -> False + prefix = either (\e -> Left (name <> ": " <> e)) Right + +-- | Close compiled fields into a documented record codec. +record :: Text -> ObjectCodec a a -> Codec a +record d o = + Codec + (documentedSchema' (nonEmpty d) (schemaOf (SObject o.fields))) + (Object . o.encode) + ( \case + Object kvs -> o.decode kvs + v -> mismatch "an object" v + ) + +-- --------------------------------------------------------------------------- +-- Sums + +-- | One constructor of a sum type. +data CaseCodec a = CaseCodec + { tag :: Text + , doc :: Maybe Text + , fields :: [Field] + , encode :: a -> Maybe [(Text, Value)] + , decode :: [(Text, Value)] -> Either Text a + } + +-- | A sum type. If no constructor has fields, it's encoded as an enumeration of +-- tags; otherwise each value is an object with a @tag@ field. +sumOf :: Text -> [CaseCodec a] -> Codec a +sumOf d = sumCodec (nonEmpty d) + +sumCodec :: Maybe Text -> [CaseCodec a] -> Codec a +sumCodec d cases + | all (null . (.fields)) cases = + Codec + (documentedSchema' d (schemaOf (SEnum [(c.tag, c.doc) | c <- cases]))) + (\a -> maybe Null (String . (.tag)) (matching a)) + ( \case + String t | Just c <- byTag t -> c.decode [] + v -> mismatch ("one of " <> T.intercalate ", " (map (.tag) cases)) v + ) + | otherwise = + Codec + (documentedSchema' d (schemaOf (SSum [Variant c.tag c.doc c.fields | c <- cases]))) + ( \a -> case [(c.tag, kvs) | c <- cases, Just kvs <- [c.encode a]] of + (t, kvs) : _ -> Object (("tag", String t) : kvs) + [] -> Null + ) + ( \case + Object kvs + | Just (String t) <- lookupField "tag" kvs -> + maybe (Left ("unknown tag " <> t)) (\c -> c.decode kvs) (byTag t) + v -> mismatch "an object with a tag" v + ) + where + matching a = find (\c -> isJust (c.encode a)) cases + byTag t = find ((== t) . (.tag)) cases + +documentedSchema' :: Maybe Text -> Schema -> Schema +documentedSchema' = maybe id documentedSchema + +nonEmpty :: Text -> Maybe Text +nonEmpty t = if T.null t then Nothing else Just t diff --git a/src/Agentic/Contract.hs b/src/Agentic/Contract.hs --- a/src/Agentic/Contract.hs +++ b/src/Agentic/Contract.hs @@ -1,437 +1,524 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} --- | Contracts: two-way codecs with documentation. A contract says how to show a --- value to a model, how to read one back, and what its schema looks like. --- --- Generic deriving (@deriving (Generic, Contract)@ and --- @deriving (Generic, Options)@) is GHC only: MicroHs's "GHC.Generics" has no --- metadata classes to read names from. Under MicroHs, write contracts out --- with 'record', 'Agentic.Contract.required', 'sumOf' and 'constructor', and --- options with 'option'. +-- | One typed structural contract, interpreted into independently chosen codecs. module Agentic.Contract - ( -- * Codecs - Codec (..) - , Contract (..) + ( Contract (..) + , Structure (..) + , Fields (..) + , Case (..) + , Constructor (..) + , FieldStyle (..) + , ScalarInfo (..) + , Outline (..) + , OutlineField (..) + , OutlineCase (..) + , Codec (..) + , ProjectionError (..) + , compileModel + , compileWith + , compileFieldsWith + , compileCaseWith + , outline + , outlineLabel + , scalar + , nominal + , mapStructure , mapCodec , reschema - -- * Records - , ObjectCodec , record , required , requiredWith , optional , lmapObject - -- * Sums - , Case , sumOf , constructor - -- * Adjusting contracts , documented , field , checked , between -#ifndef __MHS__ - -- * Generic deriving , genericContract , GContract (..) , GCases (..) - , GCase (..) , GFields (..) -#endif - -- * Enumerations + , GEnum (..) , Options (..) , OptionSet (..) , Option (..) , option , documentedOptions - , Enumeration (..) , enumeration -#ifndef __MHS__ - , GEnum (..) -#endif ) where -import Agentic.Schema +import Agentic.Codec (Codec (..), mapCodec, reschema) +import Agentic.Codec qualified as C +import Agentic.Schema hiding (Field) +import Agentic.Schema qualified as Schema import Agentic.Value -import Data.List (find) -import Data.Maybe (fromMaybe, isJust) -import Data.Text (Text) -import qualified Data.Text as T -#ifndef __MHS__ import Data.Kind (Type) -import GHC.Generics -#endif - --- --------------------------------------------------------------------------- --- Codecs - -data Codec a = Codec - { schema :: Schema - , encode :: a -> Value - , decode :: Value -> Either Text a - } +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics hiding (Constructor) +import GHC.Generics qualified +import Type.Reflection -class Contract a where - contract :: Codec a -#ifndef __MHS__ - default contract :: (Generic a, GContract (Rep a)) => Codec a - contract = genericContract -#endif +-- | Stable semantic identity chosen by the definer and explicit parameters. +-- The identity need not be a Haskell module path. Type evidence is +-- carried separately by 'Scalar'; do not identify scalars by an unqualified name. +data ScalarInfo = ScalarInfo {name :: Text, parameters :: [(Text, Text)]} + deriving (Eq, Show) -mapCodec :: (a -> b) -> (b -> a) -> Codec a -> Codec b -mapCodec to' from' c = Codec c.schema (c.encode . from') (fmap to' . c.decode) +-- | Whether the author declared named record fields or positional arguments. +data FieldStyle = RecordFields | PositionalFields deriving (Eq, Show) --- | Change a codec's schema. (A record update can't do this: t'Field' has a --- @schema@ too, so @c {schema = ...}@ is ambiguous.) -reschema :: (Schema -> Schema) -> Codec a -> Codec a -reschema f (Codec s e d) = Codec (f s) e d +-- | The declared constructor name and field style, independent of wire layout. +data Constructor = Constructor {name :: Text, style :: FieldStyle} deriving (Eq, Show) -primitive :: Shape -> (a -> Value) -> (Value -> Either Text a) -> Codec a -primitive s = Codec (schemaOf s) +-- | Executable structure. No projection is chosen by constructing this tree. +-- Mappings preserve the inner structure; use Named for a nominal wrapper and +-- Scalar for a deliberately opaque semantic leaf. +data Structure a where + Scalar :: Typeable a => ScalarInfo -> Maybe (Codec a) -> Structure a + Named :: TypeRep a -> Structure a -> Structure a + Record :: Constructor -> Fields a a -> Structure a + Sum :: [Case a] -> Structure a + List :: Structure a -> Structure [a] + Optional :: Structure a -> Structure (Maybe a) + Unit :: Structure () + Mapped :: (a -> b) -> (b -> a) -> Structure a -> Structure b + Checked :: Text -> (a -> Bool) -> Structure a -> Structure a + Documented :: Text -> Structure a -> Structure a -mismatch :: Text -> Value -> Either Text a -mismatch expected v = Left ("expected " <> expected <> ", got " <> renderJson v) +-- | Applicative fields retain getters, reconstruction, and declaration order. +data Fields r a where + Pure :: a -> Fields r a + Apply :: Fields r (a -> b) -> Fields r a -> Fields r b + Field :: Text -> Maybe Text -> Structure a -> (r -> a) -> Fields r a -instance Contract Text where - contract = primitive (SString Nothing) String $ \case - String s -> Right s - v -> mismatch "text" v +instance Functor (Fields r) where + fmap f x = Apply (Pure f) x +instance Applicative (Fields r) where + pure = Pure + (<*>) = Apply -instance Contract Bool where - contract = primitive SBool Bool $ \case - Bool b -> Right b - v -> mismatch "a boolean" v +-- | Adapt the input seen by field getters, retaining their order and reconstruction. +lmapObject :: (s -> r) -> Fields r a -> Fields s a +lmapObject f = \case + Pure a -> Pure a + Apply g x -> Apply (lmapObject f g) (lmapObject f x) + Field n d c get -> Field n d c (get . f) -instance Contract Integer where - contract = primitive SInteger Integer $ \case - Integer n -> Right n - Number d | d == fromInteger (round d) -> Right (round d) - v -> mismatch "an integer" v +-- | A sum case exposes its payload only after successful matching. The payload +-- type is existential: generic field getters cannot be applied to another arm. +data Case a where + Case :: + { constructor :: Constructor + , doc :: Maybe Text + , match :: a -> Maybe p + , inject :: p -> a + , fields :: Fields p p + } -> + Case a -instance Contract Int where - contract = mapCodec fromInteger toInteger contract +-- | A single structural authority for discovery and independently compiled codecs. +-- Derive with Generic, or build a tree explicitly with record, sumOf and scalar. +class Contract a where + -- | The typed description; no storage or model projection is selected yet. + contract :: Structure a + default contract :: (Generic a, Typeable a, GContract (Rep a)) => Structure a + contract = genericContract -instance Contract Double where - contract = primitive SNumber Number $ \case - Number d -> Right d - Integer n -> Right (fromInteger n) - v -> mismatch "a number" v +-- | Define an identifiable semantic leaf with optional default model behavior. +-- Other interpreters can supply codecs even when that default is absent. +scalar :: Typeable a => ScalarInfo -> Maybe (Codec a) -> Structure a +scalar = Scalar -instance Contract () where - contract = primitive SNull (const Null) (const (Right ())) +-- | Preserve a type's resolved nominal identity and applied arguments. Useful +-- around handwritten contracts and mappings; generic derivation adds it itself. +nominal :: forall a. Typeable a => Structure a -> Structure a +nominal = Named (typeRep @a) -instance Contract a => Contract [a] where - contract = - let c = contract @a - in Codec - (schemaOf (SArray c.schema)) - (Array . map c.encode) - ( \case - Array vs -> traverse c.decode vs - v -> mismatch "a list" v - ) +-- | Change the Haskell representation without discarding the inner structure. +-- The functions should be inverse on supported values. Wrap with nominal +-- when the outer type has a nominal identity that discovery must preserve. +mapStructure :: (a -> b) -> (b -> a) -> Structure a -> Structure b +mapStructure = Mapped -instance Contract a => Contract (Maybe a) where - contract = - let c = contract @a - in Codec - (schemaOf (SNullable c.schema)) - (maybe Null c.encode) - ( \case - Null -> Right Nothing - v -> Just <$> c.decode v - ) +-- | Close applicative fields into a documented record description. Use Named +-- (or nominal) when a handwritten record also needs nominal identity. +record :: Text -> Fields a a -> Structure a +record d = documented d . Record (Constructor "" RecordFields) -instance (Contract a, Contract b) => Contract (a, b) where - contract = - record "A pair" $ - (,) <$> required "_1" "" fst <*> required "_2" "" snd +-- | A named, documented field using its type's contract and a getter. +required :: Contract a => Text -> Text -> (r -> a) -> Fields r a +required n d = requiredWith n (nonEmpty d) contract -instance (Contract a, Contract b, Contract c) => Contract (a, b, c) where - contract = - record "A triple" $ - (,,) - <$> required "_1" "" (\(a, _, _) -> a) - <*> required "_2" "" (\(_, b, _) -> b) - <*> required "_3" "" (\(_, _, c) -> c) +-- | A named field with an explicit structural description. Missing-field +-- behavior is chosen by the projection; the model permits absent Maybe fields. +requiredWith :: Text -> Maybe Text -> Structure a -> (r -> a) -> Fields r a +requiredWith = Field --- --------------------------------------------------------------------------- --- Records +-- | A Maybe field. Models use null/absence; other projections may use tags. +optional :: Contract a => Text -> Text -> (r -> Maybe a) -> Fields r (Maybe a) +optional = required --- | The fields of an object: encodes an @i@, decodes an @o@. Build one --- applicatively with 'Agentic.Contract.required', then close it with 'record'. -data ObjectCodec i o = ObjectCodec - { fields :: [Field] - , encode :: i -> [(Text, Value)] - , decode :: [(Text, Value)] -> Either Text o - } +-- | A handwritten sum case with a predicate and applicative fields. Getters +-- must be defined for every value accepted by the predicate. For typed payload +-- matching and injection, use the existential Case constructor directly. +constructor :: Text -> Text -> (a -> Bool) -> Fields a a -> Case a +constructor n d matches = Case (Constructor n RecordFields) (nonEmpty d) (\a -> if matches a then Just a else Nothing) id -instance Functor (ObjectCodec i) where - fmap f (ObjectCodec fs e d) = ObjectCodec fs e (fmap f . d) +-- | Describe an ordered set of sum cases. The interpreter chooses their layout. +sumOf :: Text -> [Case a] -> Structure a +sumOf d = documented d . Sum -instance Applicative (ObjectCodec i) where - pure x = ObjectCodec [] (const []) (const (Right x)) - f <*> x = - ObjectCodec - (f.fields <> x.fields) - (\i -> f.encode i <> x.encode i) - (\kvs -> f.decode kvs <*> x.decode kvs) +-- | Describe the whole contract, without selecting a representation. +documented :: Text -> Structure a -> Structure a +documented "" = id +documented d = Documented d -lmapObject :: (j -> i) -> ObjectCodec i o -> ObjectCodec j o -lmapObject g (ObjectCodec fs e d) = ObjectCodec fs (e . g) d +-- | Describe one field of a record or each matching sum arm. Annotation is +-- applied immediately so it follows layout changes. A missing field raises an +-- error when the annotated structure is first evaluated. +field :: Text -> Text -> Structure a -> Structure a +field n d s = case annotateField n d s of + Just annotated -> annotated + Nothing -> error ("Agentic.Contract.field: no field named " <> T.unpack n) --- | A described field, using the field type's contract. -required :: Contract a => Text -> Text -> (r -> a) -> ObjectCodec r a -required name d = requiredWith name (nonEmpty d) contract +-- | Share a semantic predicate across projections. Decoders reject values that +-- fail it; model schemas also carry the rule as explanatory text. +checked :: Text -> (a -> Bool) -> Structure a -> Structure a +checked = Checked --- | A field with an explicit codec. Nullable fields ('Maybe') may be absent. -requiredWith :: Text -> Maybe Text -> Codec a -> (r -> a) -> ObjectCodec r a -requiredWith name d c get = - ObjectCodec - [Field name schema (not nullable)] - (\r -> [(name, c.encode (get r))]) - ( \kvs -> case lookupField name kvs of - Just v -> prefix (c.decode v) - Nothing - | nullable -> prefix (c.decode Null) - | otherwise -> Left ("missing field " <> name) - ) - where - schema = maybe id documentedSchema d c.schema - nullable = case c.schema.shape of - SNullable _ -> True - _ -> False - prefix = either (\e -> Left (name <> ": " <> e)) Right +-- | Require a decoded value to lie within the inclusive bounds. +between :: (Ord a, Show a) => a -> a -> Structure a -> Structure a +between lo hi = checked ("between " <> T.pack (show lo) <> " and " <> T.pack (show hi)) (\a -> a >= lo && a <= hi) --- | A field that may be absent. -optional :: Contract a => Text -> Text -> (r -> Maybe a) -> ObjectCodec r (Maybe a) -optional = required +nonEmpty :: Text -> Maybe Text +nonEmpty t = if T.null t then Nothing else Just t --- | Close an object codec into a contract for a record. -record :: Text -> ObjectCodec a a -> Codec a -record d o = - Codec - (documentedSchema' (nonEmpty d) (schemaOf (SObject o.fields))) - (Object . o.encode) - ( \case - Object kvs -> o.decode kvs - v -> mismatch "an object" v - ) +-- | Pure discovery data derived from the structure, independent of any codec. +-- Representation-only mappings are omitted. +data Outline + = OScalar SomeTypeRep ScalarInfo + | ONamed SomeTypeRep Outline + | ORecord Constructor [OutlineField] + | OSum [OutlineCase] + | OList Outline + | OOptional Outline + | OUnit + | OChecked Text Outline + | ODocumented Text Outline + deriving (Eq, Show) --- --------------------------------------------------------------------------- --- Sums +-- | A field's name, optional documentation, and structural outline. +data OutlineField = OutlineField + { name :: Text + , doc :: Maybe Text + , structure :: Outline + } + deriving (Eq, Show) --- | One constructor of a sum type. -data Case a = Case - { tag :: Text +-- | Constructor metadata, optional documentation, and fields in declaration order. +data OutlineCase = OutlineCase + { constructor :: Constructor , doc :: Maybe Text - , fields :: [Field] - , encode :: a -> Maybe [(Text, Value)] - , decode :: [(Text, Value)] -> Either Text a + , fields :: [OutlineField] } + deriving (Eq, Show) --- | A constructor: its tag, a description, how to recognise it, and its fields. --- --- > constructor "OneLiner" "A single line" isOneLiner (OneLiner <$> required "line" "" line) -constructor :: Text -> Text -> (a -> Bool) -> ObjectCodec a a -> Case a -constructor tag d matches o = - Case - tag - (nonEmpty d) - o.fields - (\a -> if matches a then Just (o.encode a) else Nothing) - o.decode +-- | Discover a finite contract without compiling or invoking any codec. +-- Functions and predicates remain in the tree rather than this pure view. +outline :: forall a. Structure a -> Outline +outline = \case + Scalar info _ -> OScalar (SomeTypeRep (typeRep @a)) info + Named rep c -> ONamed (SomeTypeRep rep) (outline c) + Record con fs -> ORecord con (describeFields fs) + Sum cs -> OSum [OutlineCase con d (describeFields fs) | Case con d _ _ fs <- cs] + List c -> OList (outline c) + Optional c -> OOptional (outline c) + Unit -> OUnit + Mapped _ _ c -> outline c + Checked rule _ c -> OChecked rule (outline c) + Documented d c -> ODocumented d (outline c) --- | A sum type. If no constructor has fields, it's encoded as an enumeration of --- tags; otherwise each value is an object with a @tag@ field. -sumOf :: Text -> [Case a] -> Codec a -sumOf d = sumCodec (nonEmpty d) +describeFields :: Fields r a -> [OutlineField] +describeFields = \case + Pure _ -> [] + Apply f x -> describeFields f <> describeFields x + Field n d c _ -> [OutlineField n d (outline c)] -sumCodec :: Maybe Text -> [Case a] -> Codec a -sumCodec d cases - | all (null . (.fields)) cases = - Codec - (documentedSchema' d (schemaOf (SEnum [(c.tag, c.doc) | c <- cases]))) - (\a -> maybe Null (String . (.tag)) (matching a)) - ( \case - String t | Just c <- byTag t -> c.decode [] - v -> mismatch ("one of " <> T.intercalate ", " (map (.tag) cases)) v - ) - | otherwise = - Codec - (documentedSchema' d (schemaOf (SSum [Variant c.tag c.doc c.fields | c <- cases]))) - ( \a -> case [(c.tag, kvs) | c <- cases, Just kvs <- [c.encode a]] of - (t, kvs) : _ -> Object (("tag", String t) : kvs) - [] -> Null - ) - ( \case - Object kvs - | Just (String t) <- lookupField "tag" kvs -> - maybe (Left ("unknown tag " <> t)) (\c -> c.decode kvs) (byTag t) - v -> mismatch "an object with a tag" v - ) - where - matching a = find (\c -> isJust (c.encode a)) cases - byTag t = find ((== t) . (.tag)) cases +-- | A concise display label. Scalar identity strings remain available separately. +outlineLabel :: Outline -> Text +outlineLabel = \case + ONamed rep _ -> T.pack (show rep) + OScalar rep _ -> T.pack (show rep) + ORecord con _ -> if T.null con.name then "object" else con.name + OSum _ -> "sum" + OList c -> "[" <> outlineLabel c <> "]" + OOptional c -> outlineLabel c <> "?" + OUnit -> "()" + OChecked _ c -> outlineLabel c + ODocumented _ c -> outlineLabel c --- --------------------------------------------------------------------------- --- Adjusting contracts +-- | Failures are discovered while compiling the entire structure, before values +-- are encoded. Paths identify fields, constructors and container elements. +data ProjectionError = ProjectionError {path :: [Text], problem :: Text} + deriving (Eq, Show) --- | Describe the whole type. -documented :: Text -> Codec a -> Codec a -documented d = reschema (documentedSchema d) +-- | Compile the default model representation, rejecting unsupported leaves and +-- lossy nullable combinations across the entire finite tree. Single positional +-- fields are transparent; any named zero-field Record becomes a string enum. +-- All-nullary sums use string enums; other sums use tagged objects. +compileModel :: Structure a -> Either ProjectionError (Codec a) +compileModel = compileWith (const Nothing) --- | Describe one field of a record (or of any constructor of a sum). Naming a --- field that doesn't exist is an error when the schema is first used. -field :: Text -> Text -> Codec a -> Codec a -field name d = reschema (\s -> s {shape = update s.shape}) - where - update = \case - SObject fs | any named fs -> SObject (map describeField fs) - SSum vs | any (any named . (.fields)) vs -> - SSum [Variant t vd (map describeField vfs) | Variant t vd vfs <- vs] - _ -> error ("Agentic.Contract.field: no field named " <> T.unpack name) - named f = f.name == name - describeField f@(Field n s r) - | named f = Field n (documentedSchema d s) r - | otherwise = f +-- | An open interpreter: override any typed node, delegate the remainder to the +-- model rules. An override owns both its schema and codec and must compile all +-- children it supports. The hook is consulted at EVERY node, including Named, +-- Mapped, Checked and Documented. Recursive overrides can call compileWith +-- themselves, or use compileFieldsWith / compileCaseWith for compound nodes. +-- Scalar matching can use eqTypeRep and HRefl, without unchecked casts. +compileWith :: + (forall x. Structure x -> Maybe (Either ProjectionError (Codec x))) -> + Structure a -> + Either ProjectionError (Codec a) +compileWith override = go + where + at n = either (\(ProjectionError p e) -> Left (ProjectionError (n : p) e)) Right + go :: Structure x -> Either ProjectionError (Codec x) + go tree = case override tree of + Just result -> result + Nothing -> case tree of + Scalar info mc -> maybe (Left (ProjectionError [] ("unsupported model scalar " <> info.name))) Right mc + Named rep c -> reschema (titled (T.pack (show rep))) <$> go c + Mapped to' from' c -> mapCodec to' from' <$> go c + Checked rule ok c -> do + codec <- go c + let s = codec.schema + pure $ Codec (s{checks = s.checks <> [rule]}) codec.encode $ \v -> do + a <- codec.decode v + if ok a then Right a else Left ("must be " <> rule) + Documented d c -> reschema (documentedSchema d) <$> go c + Unit -> Right (Codec (schemaOf SNull) (const Null) (\v -> case v of Null -> Right (); _ -> Left "expected null")) + List c -> do + inner <- at "[]" (go c) + pure + ( Codec + (schemaOf (SArray inner.schema)) + (Array . map inner.encode) + (\case Array vs -> traverse inner.decode vs; _ -> Left "expected a list") + ) + Optional c -> do + inner <- at "?" (go c) + if acceptsNull inner.schema + then Left (ProjectionError [] "model optional cannot distinguish nested nullable values") + else + pure + ( Codec + (schemaOf (SNullable inner.schema)) + (maybe Null inner.encode) + (\case Null -> Right Nothing; v -> Just <$> inner.decode v) + ) + Record con fs -> do + obj <- compileFieldsWith go fs + let codec = C.record "" obj + case (con.style, obj.fields) of + (_, []) + | not (T.null con.name) -> + pure $ + Codec + (schemaOf (SEnum [(con.name, Nothing)])) + (const (String con.name)) + (\case String tag | tag == con.name -> codec.decode (Object []); _ -> Left "expected the constructor name") + (PositionalFields, [Schema.Field n s _]) -> + pure + ( Codec + s + (\a -> case codec.encode a of Object kvs -> maybe Null id (lookup n kvs); _ -> Null) + (\v -> codec.decode (Object [(n, v)])) + ) + _ -> pure codec + Sum cs -> C.sumOf "" <$> traverse (compileCaseWith go) cs + acceptsNull s = case s.shape of SNullable _ -> True; SNull -> True; _ -> False --- | A constraint the wire schemas can't express. It's stated to the model and --- checked locally; a value that fails it goes back to the model. -checked :: Text -> (a -> Bool) -> Codec a -> Codec a -checked rule ok c = - Codec - (s {checks = s.checks <> [rule]}) - c.encode - ( \v -> do - a <- c.decode v - if ok a then Right a else Left ("must be " <> rule) - ) - where - s = c.schema +-- Apply field annotations before choosing a layout: an adapter may put fields +-- inside a payload object or use a completely different projected schema. +annotateField :: Text -> Text -> Structure a -> Maybe (Structure a) +annotateField n d = go + where + go :: Structure x -> Maybe (Structure x) + go = \case + Named rep c -> Named rep <$> go c + Mapped f g c -> Mapped f g <$> go c + Checked rule ok c -> Checked rule ok <$> go c + Documented doc c -> Documented doc <$> go c + Record con fs | contains fs -> Just (Record con (update fs)) + Sum cs + | any (\(Case _ _ _ _ fs) -> contains fs) cs -> + Just (Sum [Case con doc match inject (update fs) | Case con doc match inject fs <- cs]) + _ -> Nothing + contains :: Fields r x -> Bool + contains = \case + Pure _ -> False + Apply f x -> contains f || contains x + Field name _ _ _ -> name == n + update :: Fields r x -> Fields r x + update = \case + Pure x -> Pure x + Apply f x -> Apply (update f) (update x) + Field name doc c get -> Field name (if name == n then Just d else doc) c get -between :: (Ord a, Show a) => a -> a -> Codec a -> Codec a -between lo hi = - checked - ("between " <> T.pack (show lo) <> " and " <> T.pack (show hi)) - (\a -> a >= lo && a <= hi) +-- | Compile an applicative field structure using the supplied child interpreter. +-- The resulting ObjectCodec can be assembled with Agentic.Codec builders or +-- used directly for a different object layout. Nullable fields use that codec's +-- schema; an adapter can override requiredness/absence policy if necessary. +compileFieldsWith :: + (forall x. Structure x -> Either ProjectionError (Codec x)) -> + Fields r a -> + Either ProjectionError (C.ObjectCodec r a) +compileFieldsWith interpretField = go + where + go :: Fields r x -> Either ProjectionError (C.ObjectCodec r x) + go = \case + Pure a -> Right (pure a) + Apply f x -> (<*>) <$> go f <*> go x + Field n d c get -> C.requiredWith n d <$> atPath n (interpretField c) <*> pure get -documentedSchema' :: Maybe Text -> Schema -> Schema -documentedSchema' = maybe id documentedSchema +-- | Compile a case with total matching and reconstruction. This does not choose +-- the enclosing sum's wire layout; the caller owns that decision. +compileCaseWith :: + (forall x. Structure x -> Either ProjectionError (Codec x)) -> + Case a -> + Either ProjectionError (C.CaseCodec a) +compileCaseWith interpretField (Case con d match inject fs) = do + obj <- atPath con.name (compileFieldsWith interpretField fs) + pure $ C.CaseCodec con.name d obj.fields (fmap obj.encode . match) (fmap inject . obj.decode) -nonEmpty :: Text -> Maybe Text -nonEmpty t = if T.null t then Nothing else Just t +atPath :: Text -> Either ProjectionError a -> Either ProjectionError a +atPath n = either (\(ProjectionError p e) -> Left (ProjectionError (n : p) e)) Right -#ifndef __MHS__ --- --------------------------------------------------------------------------- --- Generic deriving +instance Contract Text where + contract = + scalar (ScalarInfo "Data.Text.Text" []) $ + Just $ + C.primitive (SString Nothing) String (\case String s -> Right s; v -> C.mismatch "text" v) +instance Contract Bool where + contract = + scalar (ScalarInfo "Prelude.Bool" []) $ + Just $ + C.primitive SBool Bool (\case Bool b -> Right b; v -> C.mismatch "a boolean" v) +instance Contract Integer where + contract = + scalar (ScalarInfo "Prelude.Integer" []) $ + Just $ + C.primitive SInteger Integer (\case Integer n -> Right n; Number d | not (isNaN d || isInfinite d), d == fromInteger (round d) -> Right (round d); v -> C.mismatch "an integer" v) +instance Contract Int where + contract = + scalar (ScalarInfo "Prelude.Int" []) $ + Just $ + C.primitive + SInteger + (Integer . toInteger) + ( \case + Integer n | inRange n -> Right (fromInteger n) + Number d | not (isNaN d || isInfinite d), let n = round d, d == fromInteger n, inRange n -> Right (fromInteger n) + v -> C.mismatch "an Int" v + ) + where + inRange n = n >= toInteger (minBound :: Int) && n <= toInteger (maxBound :: Int) +instance Contract Double where + contract = + scalar (ScalarInfo "Prelude.Double" []) $ + Just $ + C.primitive SNumber Number (\case Number d -> Right d; Integer n -> Right (fromInteger n); v -> C.mismatch "a number" v) +instance Contract () where contract = Unit +instance Contract a => Contract [a] where contract = List contract +instance Contract a => Contract (Maybe a) where contract = Optional contract +instance (Contract a, Contract b) => Contract (a, b) where + contract = documented "A pair" $ Record (Constructor "(,)" PositionalFields) ((,) <$> required "_1" "" fst <*> required "_2" "" snd) +instance (Contract a, Contract b, Contract c) => Contract (a, b, c) where + contract = documented "A triple" $ Record (Constructor "(,,)" PositionalFields) ((,,) <$> required "_1" "" (\(a, _, _) -> a) <*> required "_2" "" (\(_, b, _) -> b) <*> required "_3" "" (\(_, _, c) -> c)) --- | A contract built from the type's 'Generic' representation, without --- descriptions. Records become objects, sums become tagged objects, sums of --- constructors without fields become enumerations, and a constructor with a --- single unnamed field is transparent. -genericContract :: forall a. (Generic a, GContract (Rep a)) => Codec a -genericContract = mapCodec to from (gcontract @(Rep a)) +-- | Derive from Generic while preserving nominal/applied identity, constructor +-- style and field order. Model compilation alone decides whether a positional +-- wrapper is transparent. The resulting contract tree must be finite. +genericContract :: forall a. (Generic a, Typeable a, GContract (Rep a)) => Structure a +genericContract = nominal (mapStructure to from (gcontract @(Rep a))) +-- | Constraint supporting generic derivation. Use genericContract rather than +-- depending on the representation traversal itself. Trees must be finite; +-- arbitrary recursive contracts are not supported by discovery or compilation. class GContract (f :: Type -> Type) where - gcontract :: Codec (f p) - -instance (Datatype d, GCases f) => GContract (M1 D d f) where - gcontract = named $ mapCodec M1 unM1 $ case gcases @f of - [GCase _ (Just bare)] -> bare - [GCase c Nothing] | not (null c.fields) -> recordFromCase c - cs -> sumCodec Nothing (map (.gcase) cs) - where - named = reschema (titled (T.pack (datatypeName (undefined :: M1 D d f ())))) - -recordFromCase :: Case a -> Codec a -recordFromCase c = - Codec - (schemaOf (SObject c.fields)) - (Object . fromMaybe [] . c.encode) - ( \case - Object kvs -> c.decode kvs - v -> mismatch "an object" v - ) + -- | Describe a datatype representation without a nominal outer wrapper. + gcontract :: Structure (f p) -data GCase a = GCase {gcase :: Case a, _gcaseBare :: Maybe (Codec a)} +instance GContract f => GContract (M1 D d f) where + gcontract = mapStructure M1 unM1 (gcontract @f) +instance (GHC.Generics.Constructor c, GFields f) => GContract (M1 C c f) where + gcontract = Record (genericConstructor @c) (M1 <$> lmapObject unM1 (snd (gfields @f 1))) +instance (GCases f, GCases g) => GContract (f :+: g) where + gcontract = Sum (gcases @(f :+: g)) +instance GContract V1 where gcontract = Sum [] +-- | Generic sum traversal retaining constructor order and typed payloads. class GCases (f :: Type -> Type) where - gcases :: [GCase (f p)] - -instance GCases V1 where - gcases = [] + -- | Describe the cases of a generic sum. + gcases :: [Case (f p)] +instance GCases V1 where gcases = [] instance (GCases f, GCases g) => GCases (f :+: g) where - gcases = map (inject L1 (\case L1 x -> Just x; R1 _ -> Nothing)) (gcases @f) - <> map (inject R1 (\case R1 x -> Just x; L1 _ -> Nothing)) (gcases @g) - where - inject :: (x -> y) -> (y -> Maybe x) -> GCase x -> GCase y - inject wrap unwrap (GCase (Case t d fs e dec) _) = - GCase (Case t d fs (\y -> unwrap y >>= e) (fmap wrap . dec)) Nothing - -instance (Constructor c, GFields f) => GCases (M1 C c f) where gcases = - [ GCase - (Case tag Nothing o.fields (Just . o.encode) o.decode) - (mapCodec M1 unM1 <$> gbare @f) - ] - where - tag = T.pack (conName (undefined :: M1 C c f ())) - o = lmapObject unM1 (M1 <$> snd (gfields @f 1)) + map (inject L1 (\case L1 x -> Just x; _ -> Nothing)) (gcases @f) + <> map (inject R1 (\case R1 x -> Just x; _ -> Nothing)) (gcases @g) + where + inject wrap unwrap (Case con d match construct fs) = + Case con d (\y -> unwrap y >>= match) (wrap . construct) fs +instance (GHC.Generics.Constructor c, GFields f) => GCases (M1 C c f) where + gcases = [Case (genericConstructor @c) Nothing (Just . unM1) M1 (snd (gfields @f 1))] -class GFields (f :: Type -> Type) where - -- | The fields, numbering unnamed ones from the given index. - gfields :: Int -> (Int, ObjectCodec (f p) (f p)) - -- | The codec of a lone unnamed field, if that's what this is. - gbare :: Maybe (Codec (f p)) +genericConstructor :: forall (c :: Meta). GHC.Generics.Constructor c => Constructor +genericConstructor = + Constructor + (T.pack (conName (undefined :: M1 C c U1 ()))) + (if conIsRecord (undefined :: M1 C c U1 ()) then RecordFields else PositionalFields) -instance GFields U1 where - gfields n = (n, pure U1) - gbare = Nothing +-- | Generic field traversal retaining selector names and declaration order. +class GFields (f :: Type -> Type) where + -- | Number positional fields from the supplied index, returning the next index. + gfields :: Int -> (Int, Fields (f p) (f p)) +instance GFields U1 where gfields n = (n, pure U1) instance (GFields f, GFields g) => GFields (f :*: g) where gfields n = - let (n1, a) = gfields @f n - (n2, b) = gfields @g n1 + let (n1, a) = gfields @f n; (n2, b) = gfields @g n1 in (n2, (:*:) <$> lmapObject (\(x :*: _) -> x) a <*> lmapObject (\(_ :*: y) -> y) b) - gbare = Nothing - instance (Selector s, Contract a) => GFields (M1 S s (K1 i a)) where - gfields n = (n + 1, M1 . K1 <$> requiredWith name Nothing contract (unK1 . unM1)) - where - selector = selName (undefined :: M1 S s (K1 i a) ()) - name = if null selector then "_" <> T.pack (show n) else T.pack selector - gbare - | null (selName (undefined :: M1 S s (K1 i a) ())) = Just (mapCodec (M1 . K1) (unK1 . unM1) contract) - | otherwise = Nothing - -#endif - --- --------------------------------------------------------------------------- --- Enumerations + gfields n = (n + 1, M1 . K1 <$> Field name Nothing contract (unK1 . unM1)) + where + selector = selName (undefined :: M1 S s (K1 i a) ()) + name = if null selector then "_" <> T.pack (show n) else T.pack selector +-- | An enumeration value with its model-facing label and optional description. data Option a = Option { value :: a , label :: Text , doc :: Maybe Text } +-- | A documented enumeration in declaration order (lowest to highest for scores). data OptionSet a = OptionSet { doc :: Maybe Text , options :: [Option a] - -- ^ In order. For a score, this is the level order, lowest first. + -- ^ In order. For a score, this is the level order, lowest first. } -- | Types whose values are a fixed, ordered list of described options. Jev's -- @choice@ and @score@ need one. class Options a where options :: OptionSet a -#ifndef __MHS__ default options :: (Generic a, GEnum (Rep a), Show a) => OptionSet a options = OptionSet Nothing [Option v (showLabel v) Nothing | v <- map to (genum @(Rep a))] -#endif -- | One option, labelled by 'show' (the constructor's name, for an enumeration). option :: Show a => a -> Text -> Option a @@ -446,30 +533,20 @@ showLabel :: Show a => a -> Text showLabel = T.pack . show --- | Use with @deriving via@ to give an 'Options' type a matching 'Contract': --- --- > deriving via Enumeration Groan instance Contract Groan -newtype Enumeration a = Enumeration a - -instance (Options a, Eq a) => Contract (Enumeration a) where - contract = mapCodec Enumeration (\(Enumeration a) -> a) enumeration - --- | The contract of an 'Options' type: its labels, with their descriptions. -enumeration :: forall a. (Options a, Eq a) => Codec a +-- | Describe an Options type as a sum of documented nullary cases. +enumeration :: forall a. (Options a, Eq a) => Structure a enumeration = - Codec - (documentedSchema' set.doc (schemaOf (SEnum [(o.label, o.doc) | o <- opts]))) - (\a -> maybe Null (String . (.label)) (find ((== a) . (.value)) opts)) - ( \case - String t | Just o <- find ((== t) . (.label)) opts -> Right o.value - v -> mismatch ("one of " <> T.intercalate ", " (map (.label) opts)) v - ) - where - set = options @a - opts = set.options + documented (maybe "" id set.doc) $ + Sum + [ Case (Constructor o.label PositionalFields) o.doc (\a -> if a == o.value then Just () else Nothing) (const o.value) (pure ()) + | o <- set.options + ] + where + set = options @a -#ifndef __MHS__ +-- | Constraint supporting generic Options derivation. class GEnum (f :: Type -> Type) where + -- | Enumerate nullary constructors in declaration order. genum :: [f p] instance GEnum f => GEnum (M1 D d f) where @@ -480,4 +557,3 @@ instance GEnum (M1 C c U1) where genum = [M1 U1] -#endif diff --git a/src/Agentic/Core.hs b/src/Agentic/Core.hs --- a/src/Agentic/Core.hs +++ b/src/Agentic/Core.hs @@ -35,16 +35,14 @@ , module Control.Arrow ) where -import Agentic.Contract (Codec (..), Contract (..), reschema) +import Agentic.Contract (Structure, Contract (..), nominal) import Agentic.Questions (Probability, Questions, YesNo (..)) import Control.Arrow import qualified Control.Category as Category import Data.String (IsString (..)) -import Agentic.Schema (titled) import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable (Typeable, typeRep) -import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) -- | What a model step is asked to do. newtype Instruction = Instruction {text :: Text} @@ -74,8 +72,8 @@ -- which half it keeps. TakeSecond :: Step m (a, b) b Act :: (i -> m o) -> Step m i o - Draft :: Codec i -> Codec o -> Instruction -> [Tool m] -> Step m i o - Judge :: Codec i -> Questions o -> Step m i o + Draft :: Structure i -> Structure o -> Instruction -> [Tool m] -> Step m i o + Judge :: Structure i -> Questions o -> Step m i o -- | A flow from @i@ to @o@ in effect @m@. Build flows from steps with the -- 'Arrow' combinators; run them with 'Agentic.Interpret.interpret'. @@ -94,7 +92,7 @@ data Tool m where -- | A name, a description for the model, the input and output contracts, and -- the flow to run. - Tool :: Text -> Text -> Codec i -> Codec o -> Agentic m i o -> Tool m + Tool :: Text -> Text -> Structure i -> Structure o -> Agentic m i o -> Tool m toolName :: Tool m -> Text toolName (Tool name _ _ _ _) = name @@ -166,9 +164,9 @@ tool :: forall i o m. (Contract i, Contract o, Typeable i, Typeable o) => Text -> Text -> Agentic m i o -> Tool m tool name description = Tool name description (titledContract @i) (titledContract @o) --- | A type's contract, with its schema named after the type if it isn't already. -titledContract :: forall a. (Contract a, Typeable a) => Codec a -titledContract = reschema (titled (T.pack (show (typeRep (Proxy @a))))) (contract @a) +-- | Preserve a step's nominal type identity, including handwritten contracts. +titledContract :: forall a. (Contract a, Typeable a) => Structure a +titledContract = nominal (contract @a) -- | Map a flow over a list. The runtime may run the items concurrently. each :: Agentic m a b -> Agentic m [a] [b] diff --git a/src/Agentic/Describe.hs b/src/Agentic/Describe.hs --- a/src/Agentic/Describe.hs +++ b/src/Agentic/Describe.hs @@ -16,10 +16,9 @@ , descriptionValue ) where -import Agentic.Contract (Codec (..)) +import Agentic.Contract (Outline, outline, outlineLabel) import Agentic.Core import Agentic.Questions (QuestionSpec (..), Questions (..)) -import Agentic.Schema (Schema, typeLabel) import Agentic.Value (Value (..), renderJson) import Data.List (mapAccumL) import Data.Text (Text) @@ -52,20 +51,20 @@ -- ^ @act@: plain code with an effect. | DraftInfo { instruction :: Instruction - , input :: Schema - , output :: Schema + , input :: Outline + , output :: Outline , tools :: [ToolInfo] } | JudgeInfo - { input :: Schema + { input :: Outline , questions :: [QuestionSpec] } data ToolInfo = ToolInfo { name :: Text , description :: Text - , input :: Schema - , output :: Schema + , input :: Outline + , output :: Outline , body :: Description } @@ -100,12 +99,12 @@ TakeSecond -> SecondHalf Act _ -> Effect Draft input out instruction tools -> - DraftInfo instruction input.schema out.schema (map toolInfo tools) - Judge input qs -> JudgeInfo input.schema qs.specs + DraftInfo instruction (outline input) (outline out) (map toolInfo tools) + Judge input qs -> JudgeInfo (outline input) qs.specs toolInfo :: Tool m -> ToolInfo toolInfo (Tool name description input out body) = - ToolInfo name description input.schema out.schema (describe body) + ToolInfo name description (outline input) (outline out) (describe body) -- --------------------------------------------------------------------------- -- The tree view @@ -425,7 +424,7 @@ FirstHalf -> ("takeFirst", []) SecondHalf -> ("takeSecond", []) Effect -> ("act", []) - DraftInfo instruction _ out _ -> ("draft @" <> typeLabel out, [quoted instruction.text]) + DraftInfo instruction _ out _ -> ("draft @" <> outlineLabel out, [quoted instruction.text]) JudgeInfo _ [q] -> ("judge", [questionText q]) JudgeInfo _ qs -> ("judge " <> T.pack (show (length qs)) <> " questions in one request", map questionText qs) @@ -542,25 +541,24 @@ node "draft" [ ("instruction", String instruction.text) - , ("input", String (typeLabel input)) - , ("output", String (typeLabel out)) + , ("input", String (outlineLabel input)) + , ("output", String (outlineLabel out)) , ("tools", Array (map tool tools)) ] JudgeInfo input qs -> - node "judge" [("input", String (typeLabel input)), ("questions", Array (map question qs))] + node "judge" [("input", String (outlineLabel input)), ("questions", Array (map question qs))] tool t = Object [ ("name", String t.name) , ("description", String t.description) - , ("input", String (typeLabel t.input)) - , ("output", String (typeLabel t.output)) + , ("input", String (outlineLabel t.input)) + , ("output", String (outlineLabel t.output)) ] question = \case AskYesNo q -> Object [("type", String "yesNo"), ("question", String q)] AskChoice q opts -> Object [("type", String "choice"), ("question", String q), ("options", Array [String l | (l, _) <- opts])] AskScore q levels -> Object [("type", String "score"), ("question", String q), ("levels", Array [String l | (l, _) <- levels])] --- | Apply a function to a pair's second half. (MicroHs has no Functor instance --- for pairs.) +-- | Apply a function to a pair's second half. onSnd :: (b -> c) -> (a, b) -> (a, c) onSnd f (a, b) = (a, f b) diff --git a/src/Agentic/Interpret.hs b/src/Agentic/Interpret.hs --- a/src/Agentic/Interpret.hs +++ b/src/Agentic/Interpret.hs @@ -1,97 +1,143 @@ -- | Running flows. module Agentic.Interpret ( interpret + , preflight ) where -import Agentic.Contract (Codec (..)) +import Agentic.Contract (Codec (..), Structure, ProjectionError (..), compileModel) import Agentic.Core import Agentic.Questions (JudgeRequest (..), Questions (..), decodeAnswers) import Agentic.Runtime import Data.List (find) +import Data.Text (Text) -- | Run a flow with a runtime. interpret :: forall m i o. Monad m => Runtime m -> Agentic m i o -> i -> m o -interpret rt = go [] - where - go :: forall a b. [Note] -> Agentic m a b -> a -> m b - go path flow x = case flow of - Step s -> step path s x - Seq f g -> go path f x >>= go path g - Fanout f g -> do - results <- inParallel rt [Left <$> go path f x, Right <$> go path g x] +interpret rt flow input = case preflight flow of + Left e -> failWith rt e + Right () -> go [] flow input + where + go :: forall a b. [Note] -> Agentic m a b -> a -> m b + go path flow x = case flow of + Step s -> step path s x + Seq f g -> go path f x >>= go path g + Fanout f g -> do + results <- inParallel rt [Left <$> go path f x, Right <$> go path g x] + case results of + [Left b, Right c] -> pure (b, c) + _ -> error "Agentic.interpret: the runtime's parallel changed its results" + First f -> case x of (a, c) -> (\b -> (b, c)) <$> go path f a + Split f g -> case x of + (a, c) -> do + results <- inParallel rt [Left <$> go path f a, Right <$> go path g c] case results of - [Left b, Right c] -> pure (b, c) + [Left b, Right d] -> pure (b, d) _ -> error "Agentic.interpret: the runtime's parallel changed its results" - First f -> case x of (a, c) -> (\b -> (b, c)) <$> go path f a - Split f g -> case x of - (a, c) -> do - results <- inParallel rt [Left <$> go path f a, Right <$> go path g c] - case results of - [Left b, Right d] -> pure (b, d) - _ -> error "Agentic.interpret: the runtime's parallel changed its results" - Choose f g -> either (go path f) (go path g) x - Each f -> inParallel rt (map (go path f) x) - Repeat done f -> - let loop a = if done a then pure a else go path f a >>= loop - in loop x - Noted n f -> go (path <> [n]) f x + Choose f g -> either (go path f) (go path g) x + Each f -> inParallel rt (map (go path f) x) + Repeat done f -> + let loop a = if done a then pure a else go path f a >>= loop + in loop x + Noted n f -> go (path <> [n]) f x - emit :: [Note] -> Happened -> m () - emit path = rt.observe . Event path + emit :: [Note] -> Happened -> m () + emit path = rt.observe . Event path - step :: forall a b. [Note] -> Step m a b -> a -> m b - step path s x = case s of - Pass -> pure x - Wrap f -> pure (f x) - TakeFirst -> pure (fst x) - TakeSecond -> pure (snd x) - Arr f -> pure (f x) - Act f -> emit path Acted >> f x - Judge input qs - | null qs.specs -> answered (decodeAnswers qs []) - | otherwise -> do - let request = JudgeRequest (input.encode x) qs.specs - answers <- rt.systemOne.ask request - emit path (Judged request answers) - answered (decodeAnswers qs answers) - Draft inCodec out instruction tools -> do - let conversation = - Conversation - { path = path - , instruction = instruction - , input = inCodec.encode x - , inputSchema = inCodec.schema - , tools = map toolSpec tools - , outputSchema = out.schema - , history = [] - } - emit path (Drafting conversation) - let loop past = do - turn <- rt.systemTwo.ask conversation {history = past} - emit path (Turned turn) - case turn.action of - Respond v -> case out.decode v of - Right b -> pure b - Left problem -> do - emit path (OutputRejected problem) - loop (past <> [Rejected turn.raw problem]) - CallTools calls -> do - results <- inParallel rt (map (runTool path tools) calls) - loop (past <> [Called turn.raw (zip (map (.callId) calls) results)]) - loop [] - where - answered = either (failWith rt . MalformedAnswers) pure + step :: forall a b. [Note] -> Step m a b -> a -> m b + step path s x = case s of + Pass -> pure x + Wrap f -> pure (f x) + TakeFirst -> pure (fst x) + TakeSecond -> pure (snd x) + Arr f -> pure (f x) + Act f -> emit path Acted >> f x + Judge inputTree qs -> do + input <- compile path inputTree + if null qs.specs + then answered (decodeAnswers qs []) + else do + let request = JudgeRequest (input.encode x) qs.specs + answers <- rt.systemOne.ask request + emit path (Judged request answers) + answered (decodeAnswers qs answers) + Draft inTree outTree instruction toolTrees -> do + inCodec <- compile path inTree + out <- compile path outTree + tools <- traverse (compileTool path) toolTrees + let conversation = + Conversation + { path = path + , instruction = instruction + , input = inCodec.encode x + , inputSchema = inCodec.schema + , tools = map toolSpec tools + , outputSchema = out.schema + , history = [] + } + emit path (Drafting conversation) + let loop past = do + turn <- rt.systemTwo.ask conversation{history = past} + emit path (Turned turn) + case turn.action of + Respond v -> case out.decode v of + Right b -> pure b + Left problem -> do + emit path (OutputRejected problem) + loop (past <> [Rejected turn.raw problem]) + CallTools calls -> do + results <- inParallel rt (map (runTool path tools) calls) + loop (past <> [Called turn.raw (zip (map (.callId) calls) results)]) + loop [] + where + answered = either (failWith rt . MalformedAnswers) pure - runTool :: [Note] -> [Tool m] -> ToolCall -> m ToolResult - runTool path tools call = do - emit path (ToolCalled call) - result <- case find ((== call.name) . toolName) tools of - Nothing -> pure (ToolFailed ("there is no tool named " <> call.name)) - Just (Tool name _ input out body) -> case input.decode call.input of - Left problem -> pure (ToolFailed ("invalid input: " <> problem)) - Right i -> ToolOk . out.encode <$> go (path <> [Note name Nothing]) body i - emit path (ToolReturned call.callId result) - pure result + compile :: [Note] -> Structure a -> m (Codec a) + compile path = either (failWith rt . UnsupportedContract path) pure . compileModel -toolSpec :: Tool m -> ToolSpec -toolSpec (Tool name description input _ _) = ToolSpec name description input.schema + compileTool :: [Note] -> Tool m -> m (CompiledTool m) + compileTool path (Tool name doc input out body) = CompiledTool name doc <$> compile path input <*> compile path out <*> pure body + + runTool :: [Note] -> [CompiledTool m] -> ToolCall -> m ToolResult + runTool path tools call = do + emit path (ToolCalled call) + result <- case find ((== call.name) . compiledToolName) tools of + Nothing -> pure (ToolFailed ("there is no tool named " <> call.name)) + Just (CompiledTool name _ input out body) -> case input.decode call.input of + Left problem -> pure (ToolFailed ("invalid input: " <> problem)) + Right i -> ToolOk . out.encode <$> go (path <> [Note name Nothing]) body i + emit path (ToolReturned call.callId result) + pure result + +data CompiledTool m where + CompiledTool :: Text -> Text -> Codec i -> Codec o -> Agentic m i o -> CompiledTool m + +compiledToolName :: CompiledTool m -> Text +compiledToolName (CompiledTool n _ _ _ _) = n + +toolSpec :: CompiledTool m -> ToolSpec +toolSpec (CompiledTool name description input _ _) = ToolSpec name description input.schema + +-- | Validate all contracts, branches and tool bodies without executing effects. +-- Interpret runs this automatically before running any step. +preflight :: Agentic m i o -> Either FlowError () +preflight = go [] + where + check notes label c = case compileModel c of + Left (ProjectionError p e) -> Left (UnsupportedContract notes (ProjectionError (label : p) e)) + Right _ -> Right () + go :: [Note] -> Agentic m a b -> Either FlowError () + go notes = \case + Step (Draft i o _ ts) -> check notes "draft.input" i >> check notes "draft.output" o >> mapM_ (toolCheck notes) ts + Step (Judge i _) -> check notes "judge.input" i + Step _ -> Right () + Seq f g -> go notes f >> go notes g + Fanout f g -> go notes f >> go notes g + Split f g -> go notes f >> go notes g + Choose f g -> go notes f >> go notes g + First f -> go notes f + Each f -> go notes f + Repeat _ f -> go notes f + Noted n f -> go (notes <> [n]) f + toolCheck notes (Tool n _ i o body) = + let path = notes <> [Note n Nothing] + in check path "tool.input" i >> check path "tool.output" o >> go path body diff --git a/src/Agentic/Questions.hs b/src/Agentic/Questions.hs --- a/src/Agentic/Questions.hs +++ b/src/Agentic/Questions.hs @@ -8,6 +8,7 @@ , yesNo , choice , score + -- * Answers , Probability , probability @@ -17,6 +18,7 @@ , YesNo (..) , Choice (..) , Score (..) + -- * Wire types , QuestionSpec (..) , Answer (..) @@ -24,11 +26,12 @@ , decodeAnswers ) where -import Agentic.Contract (Contract (..), Option (..), OptionSet (..), Options (..), mapCodec, record, required) +import Agentic.Contract (Codec (..), Contract (..), Option (..), OptionSet (..), Options (..), ScalarInfo (..), record, required, scalar) +import Agentic.Schema (Shape (SNumber), schemaOf) import Agentic.Value (Value (..)) import Data.List (find) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T -- --------------------------------------------------------------------------- -- Probabilities @@ -85,7 +88,7 @@ data Score a = Score { position :: Double - -- ^ The probability-weighted position, from 0 (the first option) upwards. + -- ^ The probability-weighted position, from 0 (the first option) upwards. , probabilities :: [(a, Probability)] , confidence :: Probability } @@ -94,7 +97,17 @@ -- Answers have contracts, so a judgement can be a tool's output. instance Contract Probability where - contract = mapCodec toProbability probability (contract @Double) + contract = + scalar (ScalarInfo "Agentic.Questions.Probability" []) $ + Just $ + Codec + (schemaOf SNumber) + (Number . probability) + ( \case + Number d | not (isNaN d || isInfinite d) -> Right (if d <= 0 then 0 else if d >= 1 then 1 else toProbability d) + Integer n -> Right (if n <= 0 then 0 else 1) + _ -> Left "expected a finite probability" + ) instance Contract YesNo where contract = record "A yes/no judgement" (YesNo <$> required "yes" "The probability that the answer is yes" (.yes)) @@ -120,18 +133,18 @@ data QuestionSpec = AskYesNo Text - | AskChoice Text [(Text, Maybe Text)] - -- ^ Option labels with their descriptions. - | AskScore Text [(Text, Maybe Text)] - -- ^ Levels in order, lowest first. + | -- | Option labels with their descriptions. + AskChoice Text [(Text, Maybe Text)] + | -- | Levels in order, lowest first. + AskScore Text [(Text, Maybe Text)] deriving (Eq, Ord, Show) data Answer = YesNoAnswer Probability - | ChoiceAnswer Text [(Text, Probability)] Probability - -- ^ The chosen label, every label's probability, and the confidence. - | ScoreAnswer Double [(Int, Probability)] Probability - -- ^ The position, each level's probability (by index), and the confidence. + | -- | The chosen label, every label's probability, and the confidence. + ChoiceAnswer Text [(Text, Probability)] Probability + | -- | The position, each level's probability (by index), and the confidence. + ScoreAnswer Double [(Int, Probability)] Probability deriving (Eq, Show) -- | What a System One provider receives: the encoded input and the questions. @@ -154,7 +167,7 @@ } instance Functor Questions where - fmap f q = q {decoder = fmap f . q.decoder} + fmap f q = q{decoder = fmap f . q.decoder} instance Applicative Questions where pure x = Questions [] (\case [] -> Right x; _ -> Left "too many answers") @@ -182,8 +195,8 @@ ChoiceAnswer picked ps conf -> Choice <$> byLabel opts picked <*> traverse (\(l, p) -> (,p) <$> byLabel opts l) ps <*> pure conf other -> Left ("expected a choice answer, got " <> T.pack (show other)) - where - opts = (options @a).options + where + opts = (options @a).options -- | Place the input on an 'Options' type's levels, lowest first. score :: forall a. Options a => Text -> Questions (Score a) @@ -191,11 +204,11 @@ ScoreAnswer pos ps conf -> Score pos <$> traverse (\(i, p) -> (,p) <$> byIndex i) ps <*> pure conf other -> Left ("expected a score answer, got " <> T.pack (show other)) - where - opts = (options @a).options - byIndex i = case drop i opts of - o : _ | i >= 0 -> Right o.value - _ -> Left ("no level " <> T.pack (show i)) + where + opts = (options @a).options + byIndex i = case drop i opts of + o : _ | i >= 0 -> Right o.value + _ -> Left ("no level " <> T.pack (show i)) labels :: [Option a] -> [(Text, Maybe Text)] labels = map (\o -> (o.label, o.doc)) diff --git a/src/Agentic/Runtime.hs b/src/Agentic/Runtime.hs --- a/src/Agentic/Runtime.hs +++ b/src/Agentic/Runtime.hs @@ -30,6 +30,7 @@ , FlowError (..) ) where +import Agentic.Contract (ProjectionError) import Agentic.Core (Instruction, Note) import Agentic.Questions (Answer, JudgeRequest) import Agentic.Schema (Schema) @@ -119,6 +120,7 @@ data FlowError = NoSystemOne | NoSystemTwo + | UnsupportedContract [Note] ProjectionError | MalformedAnswers Text | TurnLimit Int deriving (Eq, Show) diff --git a/src/Agentic/Scripted.hs b/src/Agentic/Scripted.hs --- a/src/Agentic/Scripted.hs +++ b/src/Agentic/Scripted.hs @@ -4,13 +4,15 @@ scripted , replyingWith , respond + , modelContract , callTools + -- * System One , answering , fixedAnswers ) where -import Agentic.Contract (Codec (..), Contract (..)) +import Agentic.Contract (Codec (..), Contract (..), compileModel) import Agentic.Questions import Agentic.Runtime import Agentic.Value (Value (..)) @@ -31,9 +33,16 @@ replyingWith :: Applicative m => (Conversation -> Action) -> SystemTwo m replyingWith f = SystemTwo (pure . Turn (Raw Null) . f) --- | A final answer, encoded with its contract. +-- | A final answer, encoded with its model contract. This test-fixture helper +-- raises an error for unsupported contracts; use compileModel directly when +-- constructing responses from contracts that may be unsupported. respond :: Contract a => a -> Action -respond = Respond . contract.encode +respond = Respond . modelContract.encode + +-- | Compile a known-supported model contract for test fixtures. Unsupported +-- contracts raise an error; use compileModel to handle failure explicitly. +modelContract :: Contract a => Codec a +modelContract = either (error . ("Agentic.Scripted.modelContract: " <>) . show) id (compileModel contract) callTools :: [(Text, Value)] -> Action callTools calls = CallTools [ToolCall ("call-" <> name) name input | (name, input) <- calls] diff --git a/src/Agentic/Value.hs b/src/Agentic/Value.hs --- a/src/Agentic/Value.hs +++ b/src/Agentic/Value.hs @@ -49,6 +49,6 @@ lookupField :: Text -> [(Text, Value)] -> Maybe Value lookupField = lookup --- | 'T.concatMap', which MicroHs's "Data.Text" doesn't provide. +-- | Map and concatenate text fragments. concatMapText :: (Char -> Text) -> Text -> Text concatMapText f = T.concat . map f . T.unpack diff --git a/test/Portable.hs b/test/Portable.hs --- a/test/Portable.hs +++ b/test/Portable.hs @@ -5,15 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} --- | The core, without GHC-only features: explicit codecs, ordinary combinators, --- and a pure monad in place of IO. The same file runs under GHC (as the --- agentic-portable-test suite) and under MicroHs (in CI). +-- | Handwritten contracts, ordinary combinators, and a pure monad in place +-- of IO. Kept as the agentic-portable-test workflow regression suite on GHC. module Main (main) where import Agentic +import Agentic.Scripted (modelContract) import Data.IORef (modifyIORef, newIORef, readIORef) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import System.Exit (exitFailure) -- --------------------------------------------------------------------------- @@ -39,12 +39,12 @@ [ constructor "Circle" "A circle" isCircle (Circle <$> required "radius" "" radius) , constructor "Rect" "A rectangle" isRect (Rect <$> required "width" "" width <*> required "height" "" height) ] - where - isCircle = \case Circle _ -> True; _ -> False - isRect = \case Rect _ _ -> True; _ -> False - radius = \case Circle r -> r; _ -> 0 - width = \case Rect w _ -> w; _ -> 0 - height = \case Rect _ h -> h; _ -> 0 + where + isCircle = \case Circle _ -> True; _ -> False + isRect = \case Rect _ _ -> True; _ -> False + radius = \case Circle r -> r; _ -> 0 + width = \case Rect w _ -> w; _ -> 0 + height = \case Rect _ h -> h; _ -> 0 -- --------------------------------------------------------------------------- -- A pure monad: a script of model turns, and a log of what happened @@ -64,31 +64,32 @@ Pure g >>= k = Pure (\w -> let (a, w1) = g w in (k a).runPure w1) say :: Text -> Pure () -say t = Pure (\w -> ((), w {logged = w.logged <> [t]})) +say t = Pure (\w -> ((), w{logged = w.logged <> [t]})) -- | The handlers: scripted turns, fixed judgements, and every event recorded. handlers :: Runtime Pure handlers = (runtimeWith (\e -> error ("flow error: " <> show e))) { systemTwo = SystemTwo $ \_ -> Pure $ \w -> case w.script of - a : rest -> (Turn (Raw Null) a, w {script = rest}) + a : rest -> (Turn (Raw Null) a, w{script = rest}) [] -> error "the script ran out of turns" , systemOne = SystemOne $ \request -> pure (map answer request.questions) - , observe = \e -> Pure (\w -> ((), w {events = w.events <> [e.happened]})) + , observe = \e -> Pure (\w -> ((), w{events = w.events <> [e.happened]})) } - where - answer = \case - AskYesNo _ -> YesNoAnswer 0.9 - AskChoice _ ((l, _) : _) -> ChoiceAnswer l [(l, 1)] 1 - AskChoice _ [] -> ChoiceAnswer "" [] 0 - AskScore _ _ -> ScoreAnswer 1 [(1, 1)] 1 + where + answer = \case + AskYesNo _ -> YesNoAnswer 0.9 + AskChoice _ ((l, _) : _) -> ChoiceAnswer l [(l, 1)] 1 + AskChoice _ [] -> ChoiceAnswer "" [] 0 + AskScore _ _ -> ScoreAnswer 1 [(1, 1)] 1 -- --------------------------------------------------------------------------- -- The flows countLetters :: Tool Pure -countLetters = tool @Text @Int "count_letters" "Count the letters in some text" $ - act (\t -> say ("count_letters ran on " <> t) >> pure (T.length t)) +countLetters = + tool @Text @Int "count_letters" "Count the letters in some text" $ + act (\t -> say ("count_letters ran on " <> t) >> pure (T.length t)) writeJoke :: Tool Pure writeJoke = tool @Text @Joke "write_joke" "Write a joke about a topic" (draft @Joke "Write a joke about this topic") @@ -114,20 +115,20 @@ if ok then pure () else modifyIORef failures (+ 1) -- 1. Explicit codecs for a record and a payload-bearing sum. - check "a record round-trips through its codec" (contract.decode (contract.encode joke) == Right joke) - check "a sum with payloads round-trips" (contract.decode (contract.encode (Rect 2 3)) == Right (Rect 2 3)) - check "a sum encodes its constructor as a tag" (contract.encode (Circle 1) == Object [("tag", String "Circle"), ("radius", Number 1)]) - check "a record missing a field is rejected" (either (const True) (const False) ((contract @Joke).decode (Object [("setup", String "x")]))) + check "a record round-trips through its codec" (modelContract.decode (modelContract.encode joke) == Right joke) + check "a sum with payloads round-trips" (modelContract.decode (modelContract.encode (Rect 2 3)) == Right (Rect 2 3)) + check "a sum encodes its constructor as a tag" (modelContract.encode (Circle 1) == Object [("tag", String "Circle"), ("radius", Number 1)]) + check "a record missing a field is rejected" (either (const True) (const False) ((modelContract @Joke).decode (Object [("setup", String "x")]))) let world0 = World { script = [ CallTools [ToolCall "c1" "count_letters" (String "scarecrow")] , CallTools [ToolCall "c2" "write_joke" (String "farms")] - , Respond (contract.encode joke) -- answers the nested write_joke draft + , Respond (modelContract.encode joke) -- answers the nested write_joke draft , Respond (Object [("setup", String "only a setup")]) -- invalid: no punchline - , Respond (contract.encode joke) -- the correction - , Respond (contract.encode (Rect 2 3)) -- the shape + , Respond (modelContract.encode joke) -- the correction + , Respond (modelContract.encode (Rect 2 3)) -- the shape ] , logged = [] , events = [] @@ -143,7 +144,7 @@ -- 3. A nested drafting tool. check "the nested tool ran its own draft" (length [() | Drafting _ <- seen] == 3) - check "the nested draft's result went back as the tool's result" (any (\case ToolReturned "c2" (ToolOk v) -> contract.decode v == Right joke; _ -> False) seen) + check "the nested draft's result went back as the tool's result" (any (\case ToolReturned "c2" (ToolOk v) -> modelContract.decode v == Right joke; _ -> False) seen) -- 4. Invalid output, then a corrected response. check "the invalid output was rejected" (length [() | OutputRejected _ <- seen] == 1) diff --git a/test/ProjectionExample.hs b/test/ProjectionExample.hs new file mode 100644 --- /dev/null +++ b/test/ProjectionExample.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | An independent adapter fixture. All storage conventions are local to this +-- module; Agentic owns neither the identifier nor this storage protocol. +module ProjectionExample where + +import Agentic hiding (model) +import Agentic.Codec (CaseCodec (..), ObjectCodec (..)) +import Agentic.Contract (Structure (..)) +import Agentic.Schema (Field (..), Shape (..), Variant (..)) +import Data.Fixed (E2, Fixed (..), showFixed) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Text.Read (readMaybe) +import Type.Reflection + +newtype FactId = FactId Text deriving (Eq, Show) +instance Contract FactId where + contract = scalar (ScalarInfo "example.FactId" []) (Just identifierCodec) + +identifierCodec :: Codec FactId +identifierCodec = Codec (schemaOf (SString Nothing)) (\(FactId t) -> String t) $ \case + String t | not (T.null t) -> Right (FactId t) + _ -> Left "expected a nonempty identifier" + +-- An adapter supplied once for a library type, not for every containing record. +instance Contract (Fixed E2) where + contract = scalar (ScalarInfo "Data.Fixed.Fixed" [("resolution", "100")]) (Just decimalCodec) + +decimalCodec :: Codec (Fixed E2) +decimalCodec = Codec (schemaOf (SString Nothing)) (String . T.pack . showFixed False) $ \case + String t -> do + let (sign, unsigned) = case T.stripPrefix "-" t of Just u -> (-1, u); Nothing -> (1, t) + case T.splitOn "." unsigned of + [whole, frac] | digits whole && digits frac && T.length frac == 2 -> + case (readMaybe (T.unpack whole), readMaybe (T.unpack frac)) of + (Just w, Just f) -> + let result = MkFixed (sign * (w * 100 + f)) + in if T.pack (showFixed False result) == t then Right result else Left "noncanonical decimal" + _ -> Left "invalid decimal" + _ -> Left "expected decimal text with two fractional digits" + _ -> Left "expected exact decimal text" + where + digits t = not (T.null t) && T.all (\c -> c >= '0' && c <= '9') t + +data Sample = Sample {key :: FactId, amount :: Fixed E2, confidence :: Probability} + deriving (Generic, Contract, Eq, Show) +data Box a = Box {value :: a} deriving (Generic, Contract, Eq, Show) +data Payload = Empty | Amount (Fixed E2) | Confidence Probability + deriving (Generic, Contract, Eq, Show) + +sample :: Sample +sample = Sample (FactId "sample-1") (MkFixed 1234) (fromBasisPoints 8500) + +integerText :: Codec Integer +integerText = Codec (schemaOf (SString Nothing)) (String . T.pack . show) $ \case + String t | Just n <- readMaybe (T.unpack t), T.pack (show (n :: Integer)) == t -> Right n + _ -> Left "expected a canonical integer string" + +probabilityStorage :: Codec Probability +probabilityStorage = Codec integerText.schema (integerText.encode . toInteger . basisPoints) $ \v -> do + n <- integerText.decode v + if n < 0 || n > 10000 + then Left "basis points must be between 0 and 10000" + else Right (fromBasisPoints (fromInteger n)) + +-- | An independent projection for upstream and downstream leaves. Named types, +-- mappings, validation and lists reuse the compiler's traversal. +-- Overrides are typed, and return the schema together with its matching codec. +storage :: Structure a -> Either ProjectionError (Codec a) +storage = compileWith storageRules + +storageRules :: forall a. Structure a -> Maybe (Either ProjectionError (Codec a)) +storageRules = \case + Scalar info modelDefault -> Just $ case () of + _ + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @Probability) -> Right probabilityStorage + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @(Fixed E2)) -> Right decimalCodec + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @FactId) -> Right identifierCodec + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @Integer) -> Right integerText + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @Int) -> + Right $ + Codec + integerText.schema + (integerText.encode . toInteger) + ( \v -> do + n <- integerText.decode v + if n < toInteger (minBound :: Int) || n > toInteger (maxBound :: Int) + then Left "Int out of range" + else Right (fromInteger n) + ) + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @Text) -> defaultCodec info modelDefault + | Just HRefl <- eqTypeRep (typeRep @a) (typeRep @Bool) -> defaultCodec info modelDefault + | otherwise -> Left (ProjectionError [] ("unsupported storage scalar " <> info.name)) + Optional child -> Just $ do + c <- storage child + pure $ + Codec + (schemaOf (SSum [Variant "None" Nothing [], Variant "Some" Nothing [Field "value" c.schema True]])) + (\case Nothing -> Object [("tag", String "None")]; Just x -> Object [("tag", String "Some"), ("value", c.encode x)]) + ( \case + Object [("tag", String "None")] -> Right Nothing + Object fields | lookup "tag" fields == Just (String "Some"), Just v <- lookup "value" fields -> Just <$> c.decode v + _ -> Left "expected a None/Some tagged optional" + ) + Record con fields -> Just $ do + fs <- compileFieldsWith storage fields + let tagged = con.style == PositionalFields && not (null fs.fields) + tagField = Field "tag" (schemaOf (SEnum [(con.name, Nothing)])) True + pure $ + Codec + (schemaOf (SObject (if tagged then tagField : fs.fields else fs.fields))) + (\a -> Object ((if tagged then [("tag", String con.name)] else []) <> fs.encode a)) + ( \case + Object values | not tagged || lookup "tag" values == Just (String con.name) -> fs.decode values + _ -> Left "expected a record with its constructor tag" + ) + Sum cases -> Just $ do + compiled <- traverse (compileCaseWith storage) cases + pure $ + Codec + (schemaOf (SSum [Variant c.tag c.doc (if null c.fields then [] else [Field "payload" (schemaOf (SObject c.fields)) True]) | c <- compiled])) + ( \a -> case [(c.tag, values) | c <- compiled, Just values <- [c.encode a]] of + (tag, values) : _ -> Object ([("tag", String tag)] <> if null values then [] else [("payload", Object values)]) + [] -> Null + ) + ( \case + Object values | Just (String tag) <- lookup "tag" values -> + case [c | c <- compiled, c.tag == tag] of + c : _ + | null c.fields -> c.decode [] + | Just (Object payload) <- lookup "payload" values -> c.decode payload + _ -> Left "unknown constructor or missing payload" + _ -> Left "expected a tagged sum" + ) + Unit -> Just $ Right $ Codec (schemaOf (SObject [])) (const (Object [])) $ \case + Object [] -> Right () + _ -> Left "expected an empty object" + _ -> Nothing + where + defaultCodec info = maybe (Left (ProjectionError [] ("unsupported storage scalar " <> info.name))) Right diff --git a/test/ProjectionSpec.hs b/test/ProjectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/ProjectionSpec.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeOperators #-} + +module Main (main) where + +import Agentic hiding (model) +import Agentic.Codec qualified as C +import Agentic.Contract (Case (..), Fields (..), Structure (..)) +import Agentic.Schema (Schema (..), Shape (..), Variant (..)) +import Agentic.Schema qualified as Schema +import Agentic.Scripted (modelContract) +import Control.Exception (evaluate, try) +import Data.Either (isLeft) +import Data.Fixed (E2, Fixed (..)) +import Data.IORef +import Data.Text (Text) +import GHC.Generics (Generic) +import ProjectionExample +import Test.Hspec hiding (describe) +import Test.Hspec qualified as H +import Type.Reflection + +newtype Hidden = Hidden Text deriving (Eq, Show) +instance Contract Hidden where + contract = scalar (ScalarInfo "example.Hidden" []) Nothing + +data VariantChoice = Safe Int | Unsafe Hidden deriving (Generic, Contract) +newtype Wrapper = Wrapper (Maybe Int) + deriving stock (Generic) + deriving anyclass (Contract) +data EmptyRoot = EmptyRoot deriving (Generic, Contract, Eq, Show) + +newtype Age = Age Int + deriving stock (Generic, Eq, Show) + deriving anyclass (Contract) +type Alias = Age + +good :: Either ProjectionError a -> a +good = either (error . show) id +roundTrip :: (Eq a, Show a) => Codec a -> a -> Expectation +roundTrip c x = c.decode (c.encode x) `shouldBe` Right x + +main :: IO () +main = hspec $ do + H.describe "independent projections" $ do + it "compiles one derived Sample to storage and model codecs" $ do + let stored = good (storage (contract @Sample)) + model = modelContract @Sample + stored.encode sample `shouldBe` Object [("key", String "sample-1"), ("amount", String "12.34"), ("confidence", String "8500")] + model.encode sample `shouldBe` Object [("key", String "sample-1"), ("amount", String "12.34"), ("confidence", Number 0.85)] + roundTrip stored sample + roundTrip model sample + it "preserves negative and huge exact decimals" $ do + let c = good (storage (contract @(Fixed E2))) + mapM_ (roundTrip c . MkFixed) [-1234, 123456789012345678901234567890123456789, 0] + c.encode (MkFixed (-1234)) `shouldBe` String "-12.34" + it "rejects malformed decimal and identifier values" $ do + mapM_ + (\v -> decimalCodec.decode v `shouldSatisfy` isLeft) + [Number 12.34, String "12.345", String "01.00", String "NaN", String "-0.00", String "1e2"] + identifierCodec.decode (String "") `shouldSatisfy` isLeft + it "validates storage probability before clamping, independently of model behavior" $ do + let model = modelContract @Probability + probabilityStorage.decode (String "8500") `shouldBe` Right (fromBasisPoints 8500) + mapM_ + (\v -> probabilityStorage.decode v `shouldSatisfy` isLeft) + [String "10001", String "-1", String "85.5", String "08500", Number 8500] + model.decode (Number 1.2) `shouldBe` Right 1 + model.decode (Number 1e308) `shouldBe` Right 1 + model.decode (Number (0 / 0)) `shouldSatisfy` isLeft + model.decode (Number (1 / 0)) `shouldSatisfy` isLeft + it "shares contract checks across projections" $ do + let c = good (storage (checked "positive" (> (0 :: Integer)) contract)) + c.decode (String "-1") `shouldBe` Left "must be positive" + it "composes through lists, optionals, and payload sums" $ do + roundTrip + (good (storage (contract @[Maybe Payload]))) + [Nothing, Just Empty, Just (Amount (MkFixed (-1234))), Just (Confidence 0.85)] + it "retains all nested optional distinctions" $ do + let c = good (storage (contract @(Maybe (Maybe Int)))) + values = [Nothing, Just Nothing, Just (Just 7)] + mapM_ (roundTrip c) values + map c.encode values + `shouldBe` [ Object [("tag", String "None")] + , Object [("tag", String "Some"), ("value", Object [("tag", String "None")])] + , Object [("tag", String "Some"), ("value", Object [("tag", String "Some"), ("value", String "7")])] + ] + it "rejects lossy model optionals even through nominal and documentation wrappers" $ do + isLeft (compileModel (contract @(Maybe (Maybe Int)))) `shouldBe` True + isLeft (compileModel (Optional (documented "wrapper" (contract @Wrapper)))) `shouldBe` True + isLeft (compileModel (contract @(Maybe ()))) `shouldBe` True + isLeft (compileModel (Optional (checked "anything" (const True) (mapStructure id id (documented "nullable" (contract @(Maybe Int))))))) `shouldBe` True + it "lets storage choose unit as an empty record" $ + (good (storage (contract @()))).encode () `shouldBe` Object [] + H.describe "structural overrides" $ do + it "stores positional wrappers with tags while models remain transparent" $ do + let stored = good (storage (contract @Age)) + model = modelContract @Age + stored.encode (Age 42) `shouldBe` Object [("tag", String "Age"), ("_1", String "42")] + model.encode (Age 42) `shouldBe` Integer 42 + stored.decode (Object [("tag", String "Other"), ("_1", String "42")]) `shouldSatisfy` isLeft + it "projects a singleton nullary root to an empty object" $ do + let stored = good (storage (contract @EmptyRoot)) + stored.encode EmptyRoot `shouldBe` Object [] + roundTrip stored EmptyRoot + (modelContract @EmptyRoot).encode EmptyRoot `shouldBe` String "EmptyRoot" + it "moves sum payloads under a payload object independently of the model layout" $ do + let stored = good (storage (contract @Payload)) + model = modelContract @Payload + stored.encode (Amount (MkFixed 1234)) `shouldBe` Object [("tag", String "Amount"), ("payload", Object [("_1", String "12.34")])] + model.encode (Amount (MkFixed 1234)) `shouldBe` Object [("tag", String "Amount"), ("_1", String "12.34")] + roundTrip stored (Amount (MkFixed 1234)) + it "applies field documentation before a projection changes the sum layout" $ do + let stored = good (storage (field "_1" "quantity" (contract @Payload))) + roundTrip stored (Amount (MkFixed 1234)) + case stored.schema.shape of + SSum (_ : Variant "Amount" _ [Schema.Field "payload" (Schema _ _ _ (SObject [Schema.Field "_1" amount _])) _] : _) -> + amount.doc `shouldBe` Just "quantity" + other -> expectationFailure (show other) + it "rejects a missing field as soon as the annotation is evaluated" $ + evaluate (field "missing" "quantity" (contract @Sample)) + `shouldThrow` errorCall "Agentic.Contract.field: no field named missing" + it "applies repeated field annotations immediately, with the last one winning" $ + case outline (field "key" "second" (field "key" "first" (contract @Sample))) of + ONamed _ (ORecord _ (keyField : _)) -> do + keyField.name `shouldBe` "key" + keyField.doc `shouldBe` Just "second" + keyField.structure `shouldBe` outline (contract @FactId) + other -> expectationFailure (show other) + it "compiles existential cases without exposing nonmatching payload getters" $ do + let c :: Case (Either Int Text) + c = + Case + { constructor = Constructor "Left" PositionalFields + , doc = Nothing + , match = \case Left n -> Just n; Right _ -> Nothing + , inject = Left + , fields = Field "_1" Nothing (contract @Int) id + } + compiled :: C.CaseCodec (Either Int Text) + compiled = good (compileCaseWith compileModel c) + compiled.encode (Right "not this case") `shouldBe` Nothing + compiled.encode (Left 3) `shouldBe` Just [("_1", Integer 3)] + compiled.decode [("_1", Integer 3)] `shouldBe` Right (Left 3) + it "accepts whole in-range model Numbers for Int and rejects overflow" $ do + let c = modelContract @Int + c.decode (Number 3.0) `shouldBe` Right 3 + c.decode (Number 3.5) `shouldSatisfy` isLeft + c.decode (Integer (toInteger (maxBound :: Int) + 1)) `shouldSatisfy` isLeft + H.describe "discovery" $ do + it "omits representation mappings from outlines" $ do + let original = contract @Sample + mapped = mapStructure id id (mapStructure id id original) + outline mapped `shouldBe` outline original + outline (nominal original) `shouldBe` ONamed (SomeTypeRep (typeRep @Sample)) (outline original) + it "retains applied identity and scalar parameters" $ do + outline (contract @(Box (Fixed E2))) `shouldNotBe` outline (contract @(Box Probability)) + leaves (outline (contract @Sample)) + `shouldBe` [ ScalarInfo "example.FactId" [] + , ScalarInfo "Data.Fixed.Fixed" [("resolution", "100")] + , ScalarInfo "Agentic.Questions.Probability" [] + ] + it "preserves nominal wrappers and aliases without flattening them to scalars" $ do + outline (contract @Alias) `shouldBe` outline (contract @Age) + case outline (contract @Age) of + ONamed rep tree + | ORecord (Constructor "Age" PositionalFields) [OutlineField "_1" _ _] <- tree -> + rep `shouldBe` SomeTypeRep (typeRep @Age) + other -> expectationFailure (show other) + it "describes a singleton nullary type as a product" $ + case outline (contract @EmptyRoot) of + ONamed _ tree -> tree `shouldBe` ORecord (Constructor "EmptyRoot" PositionalFields) [] + other -> expectationFailure (show other) + it "keeps constructor declaration order and positional payload metadata" $ do + case outline (contract @Payload) of + ONamed _ tree + | OSum cs <- tree -> + [con | OutlineCase con _ _ <- cs] + `shouldBe` [Constructor "Empty" PositionalFields, Constructor "Amount" PositionalFields, Constructor "Confidence" PositionalFields] + other -> expectationFailure (show other) + H.describe "preflight" $ do + it "checks empty-list elements, absent optionals, and unused sum arms" $ do + isLeft (compileModel (contract @[Hidden])) `shouldBe` True + isLeft (compileModel (contract @(Maybe Hidden))) `shouldBe` True + isLeft (compileModel (contract @VariantChoice)) `shouldBe` True + it "describes a flow even when its model projection is unsupported" $ + renderTree (describe (draft @Hidden @() @IO "hidden")) `shouldSatisfy` (not . null . show) + it "rejects unsupported tool results before any effect or provider call" $ do + effects <- newIORef (0 :: Int) + calls <- newIORef (0 :: Int) + let rt = runtime{systemTwo = SystemTwo (\_ -> modifyIORef' calls (+ 1) >> pure (Turn (Raw Null) (Respond (String "done"))))} + hiddenTool = tool @() @Hidden "hidden" "hidden output" (arr (const (Hidden "secret"))) + flow = act (\() -> modifyIORef' effects (+ 1)) >>> draftWith @Text [hiddenTool] "test" + result <- try @FlowError (interpret rt flow ()) + result `shouldSatisfy` (\case Left (UnsupportedContract _ _) -> True; _ -> False) + readIORef calls `shouldReturn` 0 + readIORef effects `shouldReturn` 0 + it "retains named flow context and structured projection paths" $ + case preflight (draft @Hidden @() @IO "hidden" `named` "make hidden") of + Left (UnsupportedContract notes (ProjectionError path _)) -> do + notes `shouldBe` [Note "make hidden" Nothing] + path `shouldBe` ["draft.output"] + other -> expectationFailure (show other) + it "rejects unsupported tool inputs and nested tool body contracts" $ do + let inputTool = tool @Hidden @Text "input" "" (arr (const "ok")) + bodyTool = tool @() @Text "body" "" (draft @Hidden "hidden" >>> arr (const "ok")) + preflight (draftWith @Text @() @IO [inputTool] "test") `shouldSatisfy` isLeft + preflight (draftWith @Text @() @IO [bodyTool] "test") `shouldSatisfy` isLeft + +leaves :: Outline -> [ScalarInfo] +leaves = \case + OScalar _ info -> [info] + ONamed _ c -> leaves c + ORecord _ fs -> concat [leaves c | OutlineField _ _ c <- fs] + OSum cs -> concat [leaves c | OutlineCase _ _ fs <- cs, OutlineField _ _ c <- fs] + OList c -> leaves c + OOptional c -> leaves c + OUnit -> [] + OChecked _ c -> leaves c + ODocumented _ c -> leaves c diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,14 +1,14 @@ module Main (main) where import Agentic -import Agentic.Scripted import Agentic.Schema (Field (..), Schema (..), Shape (..)) +import Agentic.Scripted import Data.IORef import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Generics (Generic) import Test.Hspec hiding (describe) -import qualified Test.Hspec +import Test.Hspec qualified -- --------------------------------------------------------------------------- -- README types @@ -34,18 +34,18 @@ , option Unbearable "People get up and leave" ] -deriving via Enumeration Groan instance Contract Groan +instance Contract Groan where contract = enumeration newtype Rating = Rating Int deriving (Show, Eq) instance Contract Rating where - contract = mapCodec Rating (\(Rating n) -> n) (between 1 10 contract) + contract = mapStructure Rating (\(Rating n) -> n) (between 1 10 contract) data Review = Review {funny :: YesNo, groan :: Score Groan} deriving (Show, Eq) -documentedJoke :: Codec Joke +documentedJoke :: Structure Joke documentedJoke = record "A joke, split into its parts" $ Joke @@ -69,7 +69,7 @@ testRuntime :: [Action] -> Probability -> IO (Runtime IO) testRuntime turns p = do two <- scripted turns - pure runtime {systemOne = fixedAnswers p, systemTwo = two} + pure runtime{systemOne = fixedAnswers p, systemTwo = two} roundTrips :: (Eq a, Show a) => Codec a -> a -> Expectation roundTrips c a = c.decode (c.encode a) `shouldBe` Right a @@ -78,33 +78,33 @@ main = hspec $ do describe' "Contracts" $ do it "round-trips a derived record" $ - roundTrips contract joke + roundTrips modelContract joke it "round-trips a derived sum as tagged objects" $ do - roundTrips contract (OneLiner "I'm on a seafood diet.") - contract.encode (OneLiner "x") + roundTrips modelContract (OneLiner "I'm on a seafood diet.") + modelContract.encode (OneLiner "x") `shouldBe` Object [("tag", String "OneLiner"), ("line", String "x")] it "encodes an Options type as its labels" $ do - contract.encode Solid `shouldBe` String "Solid" - contract.decode (String "Unbearable") `shouldBe` Right Unbearable + modelContract.encode Solid `shouldBe` String "Solid" + modelContract.decode (String "Unbearable") `shouldBe` Right Unbearable it "names derived schemas after their type" $ - (contract @Joke).schema.title `shouldBe` Just "Joke" + (modelContract @Joke).schema.title `shouldBe` Just "Joke" it "keeps descriptions written in the codec" $ - case documentedJoke.schema.shape of + case (either (error . show) id (compileModel documentedJoke)).schema.shape of SObject fs -> map ((.doc) . (.schema)) fs `shouldBe` map Just ["The style of joke", "The setup line", "The line that lands it"] other -> expectationFailure (show other) it "adds descriptions to a derived contract" $ - case (field "punchline" "No explanation" (contract @Joke)).schema.shape of + case (either (error . show) id (compileModel (field "punchline" "No explanation" (contract @Joke)))).schema.shape of SObject fs -> map ((.doc) . (.schema)) fs `shouldBe` [Nothing, Nothing, Just "No explanation"] other -> expectationFailure (show other) it "checks constraints the schema can't express" $ do - (contract @Rating).decode (Integer 7) `shouldBe` Right (Rating 7) - (contract @Rating).decode (Integer 11) `shouldBe` Left "must be between 1 and 10" + (modelContract @Rating).decode (Integer 7) `shouldBe` Right (Rating 7) + (modelContract @Rating).decode (Integer 11) `shouldBe` Left "must be between 1 and 10" describe' "Questions" $ do it "batches combined questions into one request" $ @@ -149,9 +149,9 @@ interpret rt (keep 0.9 funny) [joke, joke] `shouldReturn` [] it "gates into branches" $ do - rt <- testRuntime [respond joke {genre = "kids"}] 0.5 + rt <- testRuntime [respond joke{genre = "kids"}] 0.5 let kidFriendly = gate 0.9 funny >>> (draft @Joke "rewrite this joke for a 10-year-old" ||| returnA) - interpret rt kidFriendly joke `shouldReturn` joke {genre = "kids"} + interpret rt kidFriendly joke `shouldReturn` joke{genre = "kids"} it "runs structure: fanout and each" $ do rt <- testRuntime [respond joke, respond (Rating 3)] 1 @@ -277,5 +277,5 @@ , "└─ tool research draft @Text \"research this\"" , " └─ tool research (see above)" ] - where - describe' = Test.Hspec.describe + where + describe' = Test.Hspec.describe