agentic 0.2.0.5 → 0.2.1.0

raw patch · 17 files changed

+1277/−545 lines, 17 filesdep ~agenticPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: agentic

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−0
• README.md +28/−4
• agentic.cabal +17/−4
• src/Agentic.hs +4/−3
• src/Agentic/Codec.hs +149/−0
• src/Agentic/Contract.hs +429/−353
• src/Agentic/Core.hs +8/−10
• src/Agentic/Describe.hs +16/−18
• src/Agentic/Interpret.hs +125/−79
• src/Agentic/Questions.hs +33/−20
• src/Agentic/Runtime.hs +2/−0
• src/Agentic/Scripted.hs +12/−3
• src/Agentic/Value.hs +1/−1
• test/Portable.hs +30/−29
• test/ProjectionExample.hs +147/−0
• test/ProjectionSpec.hs +220/−0
• test/Spec.hs +21/−21

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

@@ -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?"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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