agentic 0.2.0.1 → 0.2.0.2

raw patch · 10 files changed

+254/−34 lines, 10 filesdep ~agenticdep ~basedep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: agentic, base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• README.md +1/−1
• agentic.cabal +12/−1
• src/Agentic.hs +3/−3
• src/Agentic/Contract.hs +32/−23
• src/Agentic/Core.hs +11/−1
• src/Agentic/Describe.hs +12/−3
• src/Agentic/Value.hs +5/−1
• test/Portable.hs +162/−0
• test/Spec.hs +1/−1

@@ -1,5 +1,20 @@ # Changelog for agentic +## 0.2.0.2 - 2026-10-01++* The core now builds and runs under MicroHs as well as GHC. Generic+  deriving of `Contract` and `Options` is GHC only; under MicroHs, write+  contracts with `record`, `required`, `sumOf` and `constructor`.+* `option` takes an option's label from `show` instead of Generics, so it works+  on both compilers. For an enumeration the label is still the constructor's+  name.+* `Tool`'s constructor is positional; `toolName` and `toolDescription` are+  functions.+* `Agentic` no longer exports the constructors of `Shape` and `Variant`, which+  clashed with users' own types. Provider code imports them from+  `Agentic.Schema`.+* A new `agentic-portable-test` suite, which CI also runs under MicroHs.+ ## 0.2.0.1 - 2026-10-01  * The README now appears on the Hackage package page.

@@ -21,7 +21,7 @@  | Package | What it's for | |---|---|-| `agentic` | flows, contracts, questions, the runtime and the interpreter (depends only on `base` and `text`) |+| `agentic` | flows, contracts, questions, the runtime and the interpreter (depends only on `base` and `text`, and builds with MicroHs too) | | `agentic-jev` | Jev as System One | | `agentic-anthropic` | Claude as System Two (or System One) | | `agentic-openai` | OpenAI as System Two (or System One) |

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               agentic-version:            0.2.0.1+version:            0.2.0.2 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.@@ -66,3 +66,14 @@     , 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.+test-suite agentic-portable-test+  import:           shared+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Portable.hs+  build-depends:+    , agentic+    , base+    , text

@@ -3,7 +3,7 @@ -- -- This module is for writing and running flows. The fields of the types that -- providers work with (t'Conversation', t'Schema' and t'Field'), and the--- constructors of 'Format', aren't exported here, so they don't clash with your+-- constructors of 'Format', t'Shape' and t'Variant', aren't exported here, so they don't clash with your -- own types; provider code imports "Agentic.Runtime" and "Agentic.Schema" -- directly. module Agentic@@ -26,8 +26,8 @@ import Agentic.Questions import Agentic.Runtime hiding (Conversation (..)) import Agentic.Runtime (Conversation)-import Agentic.Schema hiding (Field (..), Format (..), Schema (..))-import Agentic.Schema (Field, Format, Schema)+import Agentic.Schema hiding (Field (..), Format (..), Schema (..), Shape (..), Variant (..))+import Agentic.Schema (Field, Format, Schema, Shape, Variant) import Agentic.Settings import Agentic.Value import Agentic.ViaLLM

@@ -1,7 +1,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}  -- | 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', 'required', 'sumOf' and 'constructor', and options with+-- 'option'. module Agentic.Contract   ( -- * Codecs     Codec (..)@@ -23,12 +30,14 @@   , field   , checked   , between+#ifndef __MHS__     -- * Generic deriving   , genericContract   , GContract (..)   , GCases (..)   , GCase (..)   , GFields (..)+#endif     -- * Enumerations   , Options (..)   , OptionSet (..)@@ -37,18 +46,21 @@   , described   , Enumeration (..)   , enumeration+#ifndef __MHS__   , GEnum (..)-  , GConName (..)+#endif   ) where  import Agentic.Schema import Agentic.Value-import Data.Kind (Type) 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@@ -61,8 +73,10 @@  class Contract a where   contract :: Codec a+#ifndef __MHS__   default contract :: (Generic a, GContract (Rep a)) => Codec a   contract = genericContract+#endif  mapCodec :: (a -> b) -> (b -> a) -> Codec a -> Codec b mapCodec to' from' c = Codec (codecSchema c) (encode c . from') (fmap to' . decode c)@@ -302,6 +316,7 @@ nonEmpty :: Text -> Maybe Text nonEmpty t = if T.null t then Nothing else Just t +#ifndef __MHS__ -- --------------------------------------------------------------------------- -- Generic deriving @@ -389,6 +404,8 @@     | null (selName (undefined :: M1 S s (K1 i a) ())) = Just (mapCodec (M1 . K1) (unK1 . unM1) contract)     | otherwise = Nothing +#endif+ -- --------------------------------------------------------------------------- -- Enumerations @@ -408,18 +425,22 @@ -- @choice@ and @score@ need one. class Options a where   options :: OptionSet a-  default options :: (Generic a, GEnum (Rep a), GConName (Rep a)) => OptionSet a-  options = OptionSet Nothing [Option v (conLabel v) Nothing | v <- map to (genum @(Rep a))]+#ifndef __MHS__+  default options :: (Generic a, GEnum (Rep a), Show a) => OptionSet a+  options = OptionSet Nothing [Option v (label v) Nothing | v <- map to (genum @(Rep a))]+#endif --- | One option, labelled with its constructor name.-option :: (Generic a, GConName (Rep a)) => a -> Text -> Option a-option v d = Option v (conLabel v) (nonEmpty d)+-- | One option, labelled by 'show' (the constructor's name, for an enumeration).+option :: Show a => a -> Text -> Option a+option v d = Option v (label v) (nonEmpty d)  described :: Text -> [Option a] -> OptionSet a described d = OptionSet (nonEmpty d) -conLabel :: (Generic a, GConName (Rep a)) => a -> Text-conLabel = T.pack . gconName . from+-- | An option's label: what the model sees and answers with. For an+-- enumeration, 'show' gives the constructor's name.+label :: Show a => a -> Text+label = T.pack . show  -- | Use with @deriving via@ to give an 'Options' type a matching 'Contract': --@@ -443,6 +464,7 @@     set = options @a     opts = optionList set +#ifndef __MHS__ class GEnum (f :: Type -> Type) where   genum :: [f p] @@ -454,17 +476,4 @@  instance GEnum (M1 C c U1) where   genum = [M1 U1]--class GConName (f :: Type -> Type) where-  gconName :: f p -> String--instance GConName f => GConName (M1 D d f) where-  gconName (M1 x) = gconName x--instance (GConName f, GConName g) => GConName (f :+: g) where-  gconName = \case-    L1 x -> gconName x-    R1 x -> gconName x--instance Constructor c => GConName (M1 C c f) where-  gconName = conName+#endif

@@ -6,6 +6,8 @@     Agentic (..)   , Step (..)   , Tool (..)+  , toolName+  , toolDescription   , Note (..)   , Instruction (..)     -- * Steps@@ -80,7 +82,15 @@  -- | A named flow a model can call. data Tool m where-  Tool :: {toolName :: Text, toolDescription :: Text, toolInput :: Codec i, toolOutput :: Codec o, toolBody :: Agentic m i o} -> Tool m+  -- | 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++toolName :: Tool m -> Text+toolName (Tool name _ _ _ _) = name++toolDescription :: Tool m -> Text+toolDescription (Tool _ description _ _ _) = description  instance Category.Category (Agentic m) where   id = Step Pass

@@ -120,10 +120,10 @@   Leaf Identity -> (seen, [])   Leaf Glue -> (seen, [])   Leaf info -> leaf Nothing info-  Sequence ds -> concat <$> mapAccumL trees seen ds+  Sequence ds -> onSnd concat (mapAccumL trees seen ds)   Together ds ->     let keeping = if any passes ds then "  (keeping its input)" else ""-     in case concat <$> mapAccumL parallel seen (filter (not . passes) ds) of+     in case onSnd concat (mapAccumL parallel seen (filter (not . passes) ds)) of           (seen', [Node t cs]) -> (seen', [Node (t <> keeping) cs])           (seen', ts) -> (seen', [Node ("together" <> keeping) ts])   Halves l r ->@@ -414,7 +414,7 @@       Uses -> ["style=dotted", "arrowhead=none"]       Again -> ["style=dashed"]     str t = "\"" <> inner t <> "\""-    inner = T.concatMap (\case '"' -> "\\\""; '\\' -> "\\\\"; c -> T.singleton c)+    inner = concatMapText (\case '"' -> "\\\""; '\\' -> "\\\\"; c -> T.singleton c)  -- | Is the node with this id inside the box with that id? inBox :: Text -> Text -> [Item] -> Bool@@ -490,3 +490,12 @@       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])]++-- | 'T.concatMap', which MicroHs's "Data.Text" doesn't provide.+concatMapText :: (Char -> Text) -> Text -> Text+concatMapText f = T.concat . map f . T.unpack++-- | Apply a function to a pair's second half. (MicroHs has no Functor instance+-- for pairs.)+onSnd :: (b -> c) -> (a, b) -> (a, c)+onSnd f (a, b) = (a, f b)

@@ -34,7 +34,7 @@   Object kvs -> "{" <> T.intercalate "," [quote k <> ":" <> renderJson v | (k, v) <- kvs] <> "}"  quote :: Text -> Text-quote s = "\"" <> T.concatMap escape s <> "\""+quote s = "\"" <> concatMapText escape s <> "\""   where     escape = \case       '"' -> "\\\""@@ -48,3 +48,7 @@  lookupField :: Text -> [(Text, Value)] -> Maybe Value lookupField = lookup++-- | 'T.concatMap', which MicroHs's "Data.Text" doesn't provide.+concatMapText :: (Char -> Text) -> Text -> Text+concatMapText f = T.concat . map f . T.unpack

@@ -0,0 +1,162 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# 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).+module Main (main) where++import Agentic+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Text (Text)+import qualified Data.Text as T+import System.Exit (exitFailure)++-- ---------------------------------------------------------------------------+-- Explicit codecs: a record, and a sum with payloads++data Joke = Joke Text Text+  deriving (Show, Eq)++instance Contract Joke where+  contract =+    record "A joke" $+      Joke+        <$> required "setup" "The setup line" (\(Joke s _) -> s)+        <*> required "punchline" "The line that lands it" (\(Joke _ p) -> p)++data Figure = Circle Double | Rect Double Double+  deriving (Show, Eq)++instance Contract Figure where+  contract =+    sumOf+      "A shape"+      [ 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++-- ---------------------------------------------------------------------------+-- A pure monad: a script of model turns, and a log of what happened++data World = World {script :: [Action], logged :: [Text], events :: [Happened]}++newtype Pure a = Pure {runPure :: World -> (a, World)}++instance Functor Pure where+  fmap f (Pure g) = Pure (\w -> let (a, w') = g w in (f a, w'))++instance Applicative Pure where+  pure a = Pure (\w -> (a, w))+  Pure f <*> Pure g = Pure (\w -> let (h, w1) = f w; (a, w2) = g w1 in (h a, w2))++instance Monad Pure where+  Pure g >>= k = Pure (\w -> let (a, w1) = g w in runPure (k a) w1)++say :: Text -> Pure ()+say t = Pure (\w -> ((), w {logged = logged w <> [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 script w of+        a : rest -> (Turn (Raw Null) a, w {script = rest})+        [] -> error "the script ran out of turns"+    , systemOne = SystemOne $ \request -> pure (map answer (requestQuestions request))+    , observe = \e -> Pure (\w -> ((), w {events = events w <> [happened e]}))+    }+  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))++writeJoke :: Tool Pure+writeJoke = tool @Text @Joke "write_joke" "Write a joke about a topic" (draft @Joke "Write a joke about this topic")++jokeAndFigure :: Agentic Pure Text (Joke, Figure)+jokeAndFigure =+  draftWith @Joke [countLetters, writeJoke] "Write a joke, using the tools"+    &&& draft @Figure "Pick a shape"++review :: Agentic Pure Joke (YesNo, YesNo)+review = judge ((,) <$> yesNo "Is it funny?" <*> yesNo "Is it kind?")++joke :: Joke+joke = Joke "Why was the scarecrow promoted?" "He was outstanding in his field."++-- ---------------------------------------------------------------------------++main :: IO ()+main = do+  failures <- newIORef (0 :: Int)+  let check name ok = do+        putStrLn ((if ok then "ok   " else "FAIL ") <> name)+        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" (decode contract (encode contract joke) == Right joke)+  check "a sum with payloads round-trips" (decode contract (encode contract (Rect 2 3)) == Right (Rect 2 3))+  check "a sum encodes its constructor as a tag" (encode contract (Circle 1) == Object [("tag", String "Circle"), ("radius", Number 1)])+  check "a record missing a field is rejected" (either (const True) (const False) (decode (contract @Joke) (Object [("setup", String "x")])))++  let world0 =+        World+          { script =+              [ CallTools [ToolCall "c1" "count_letters" (String "scarecrow")]+              , CallTools [ToolCall "c2" "write_joke" (String "farms")]+              , Respond (encode contract joke) -- answers the nested write_joke draft+              , Respond (Object [("setup", String "only a setup")]) -- invalid: no punchline+              , Respond (encode contract joke) -- the correction+              , Respond (encode contract (Rect 2 3)) -- the shape+              ]+          , logged = []+          , events = []+          }+      ((result, verdict), world) =+        runPure ((,) <$> interpret handlers jokeAndFigure "scarecrows" <*> interpret handlers review joke) world0+      seen = events world++  -- 2. A scripted tool call runs its typed body, and the draft continues.+  check "the tool's typed body ran with the model's input" (logged world == ["count_letters ran on scarecrow"])+  check "the tool's typed result went back to the model" (any (\case ToolReturned "c1" (ToolOk (Integer 9)) -> True; _ -> False) seen)+  check "the draft continued to a typed response" (result == (joke, Rect 2 3))++  -- 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) -> decode contract v == Right joke; _ -> False) seen)++  -- 4. Invalid output, then a corrected response.+  check "the invalid output was rejected" (length [() | OutputRejected _ <- seen] == 1)+  check "every scripted turn was used" (null (script world))++  -- 5. An applicative judgement batch: two questions, one request.+  check "two questions went in one request" ([length (requestQuestions r) | Judged r _ <- seen] == [2])+  check "the answers decoded to typed values" (verdict == (YesNo 0.9, YesNo 0.9))++  -- 6. Describing the flow invokes no handlers: describe has no runtime to call.+  let tree = renderTree (describe jokeAndFigure)+  check "describe shows the drafts and both tools" (all (`T.isInfixOf` tree) ["draft @Joke", "tool count_letters  act", "tool write_joke  draft @Joke", "draft @Figure"])++  -- 7. All of the above ran in Pure, not IO.+  n <- readIORef failures+  if n == 0 then putStrLn "all checks passed" else putStrLn (show n <> " checks failed") >> exitFailure

@@ -2,7 +2,7 @@  import Agentic import Agentic.Scripted-import Agentic.Schema (Field (..), Schema (..))+import Agentic.Schema (Field (..), Schema (..), Shape (..)) import Data.IORef import Data.Text (Text) import qualified Data.Text as T