agentic (empty) → 0.2.0.0
raw patch · 16 files changed
+2313/−0 lines, 16 filesdep +agenticdep +basedep +hspec
Dependencies added: agentic, base, hspec, text
Files
- CHANGELOG.md +5/−0
- LICENSE +25/−0
- agentic.cabal +66/−0
- src/Agentic.hs +33/−0
- src/Agentic/Contract.hs +470/−0
- src/Agentic/Core.hs +175/−0
- src/Agentic/Describe.hs +492/−0
- src/Agentic/Interpret.hs +97/−0
- src/Agentic/Questions.hs +200/−0
- src/Agentic/Runtime.hs +187/−0
- src/Agentic/Schema.hs +86/−0
- src/Agentic/Scripted.hs +52/−0
- src/Agentic/Settings.hs +49/−0
- src/Agentic/Value.hs +50/−0
- src/Agentic/ViaLLM.hs +69/−0
- test/Spec.hs +257/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for agentic++## 0.2.0.0 - 2026-10-01++First release of the v2 design.
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2026, Tom Wells++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ agentic.cabal view
@@ -0,0 +1,66 @@+cabal-version: 3.0+name: agentic+version: 0.2.0.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.+license: BSD-2-Clause+license-file: LICENSE+author: Tom Wells+maintainer: drshade@gmail.com+copyright: 2026 Tom Wells+category: AI+homepage: https://github.com/drshade/haskell-agentic+bug-reports: https://github.com/drshade/haskell-agentic/issues+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1++source-repository head+ type: git+ location: https://github.com/drshade/haskell-agentic.git+ subdir: agentic++common shared+ default-language: GHC2021+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DerivingVia+ GADTs+ LambdaCase+ OverloadedStrings+ RankNTypes+ ghc-options: -Wall -Wno-name-shadowing++library+ import: shared+ hs-source-dirs: src+ exposed-modules:+ Agentic+ Agentic.Contract+ Agentic.Core+ Agentic.Describe+ Agentic.Interpret+ Agentic.Questions+ Agentic.Runtime+ Agentic.Schema+ Agentic.Scripted+ Agentic.Settings+ Agentic.Value+ Agentic.ViaLLM+ build-depends:+ , base >=4.18 && <5+ , text >=2.0 && <2.2++test-suite agentic-test+ import: shared+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ , agentic ==0.2.*+ , base >=4.18 && <5+ , hspec >=2.10 && <3+ , text >=2.0 && <2.2
+ src/Agentic.hs view
@@ -0,0 +1,33 @@+-- | Composable agentic workflows: typed steps, mixing LLMs and System One+-- models such as Jev, that you can inspect before you run them.+--+-- 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+-- own types; provider code imports "Agentic.Runtime" and "Agentic.Schema"+-- directly.+module Agentic+ ( module Agentic.Core+ , module Agentic.Contract+ , module Agentic.Questions+ , module Agentic.Runtime+ , module Agentic.Interpret+ , module Agentic.Describe+ , module Agentic.Value+ , module Agentic.Schema+ , module Agentic.ViaLLM+ , module Agentic.Settings+ ) where++import Agentic.Contract+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 (..))+import Agentic.Schema (Field, Format, Schema)+import Agentic.Settings+import Agentic.Value+import Agentic.ViaLLM
+ src/Agentic/Contract.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | 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.+module Agentic.Contract+ ( -- * Codecs+ Codec (..)+ , Contract (..)+ , mapCodec+ -- * Records+ , ObjectCodec+ , record+ , required+ , requiredWith+ , optional+ , lmapObject+ -- * Sums+ , Case+ , sumOf+ , constructor+ -- * Adjusting contracts+ , documented+ , field+ , checked+ , between+ -- * Generic deriving+ , genericContract+ , GContract (..)+ , GCases (..)+ , GCase (..)+ , GFields (..)+ -- * Enumerations+ , Options (..)+ , OptionSet (..)+ , Option (..)+ , option+ , described+ , Enumeration (..)+ , enumeration+ , GEnum (..)+ , GConName (..)+ ) 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+import GHC.Generics++-- ---------------------------------------------------------------------------+-- Codecs++data Codec a = Codec+ { codecSchema :: Schema+ , encode :: a -> Value+ , decode :: Value -> Either Text a+ }++class Contract a where+ contract :: Codec a+ default contract :: (Generic a, GContract (Rep a)) => Codec a+ contract = genericContract++mapCodec :: (a -> b) -> (b -> a) -> Codec a -> Codec b+mapCodec to' from' c = Codec (codecSchema c) (encode c . from') (fmap to' . decode c)++primitive :: Shape -> (a -> Value) -> (Value -> Either Text a) -> Codec a+primitive s = Codec (schemaOf s)++mismatch :: Text -> Value -> Either Text a+mismatch expected v = Left ("expected " <> expected <> ", got " <> renderJson v)++instance Contract Text where+ contract = primitive (SString Nothing) String $ \case+ String s -> Right s+ v -> mismatch "text" v++instance Contract Bool where+ contract = primitive SBool Bool $ \case+ Bool b -> Right b+ v -> mismatch "a boolean" v++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++instance Contract Int where+ contract = mapCodec fromInteger toInteger contract++instance Contract Double where+ contract = primitive SNumber Number $ \case+ Number d -> Right d+ Integer n -> Right (fromInteger n)+ v -> mismatch "a number" v++instance Contract () where+ contract = primitive SNull (const Null) (const (Right ()))++instance Contract a => Contract [a] where+ contract =+ let c = contract @a+ in Codec+ (schemaOf (SArray (codecSchema c)))+ (Array . map (encode c))+ ( \case+ Array vs -> traverse (decode c) vs+ v -> mismatch "a list" v+ )++instance Contract a => Contract (Maybe a) where+ contract =+ let c = contract @a+ in Codec+ (schemaOf (SNullable (codecSchema c)))+ (maybe Null (encode c))+ ( \case+ Null -> Right Nothing+ v -> Just <$> decode c v+ )++instance (Contract a, Contract b) => Contract (a, b) where+ contract =+ record "A pair" $+ (,) <$> required "_1" "" fst <*> required "_2" "" snd++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)++-- ---------------------------------------------------------------------------+-- Records++-- | The fields of an object: encodes an @i@, decodes an @o@. Build one+-- applicatively with 'required', then close it with 'record'.+data ObjectCodec i o = ObjectCodec+ { objectFields :: [Field]+ , objectEncode :: i -> [(Text, Value)]+ , objectDecode :: [(Text, Value)] -> Either Text o+ }++instance Functor (ObjectCodec i) where+ fmap f o = o {objectDecode = fmap f . objectDecode o}++instance Applicative (ObjectCodec i) where+ pure x = ObjectCodec [] (const []) (const (Right x))+ f <*> x =+ ObjectCodec+ (objectFields f <> objectFields x)+ (\i -> objectEncode f i <> objectEncode x i)+ (\kvs -> objectDecode f kvs <*> objectDecode x kvs)++lmapObject :: (j -> i) -> ObjectCodec i o -> ObjectCodec j o+lmapObject g o = o {objectEncode = objectEncode o . g}++-- | 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++-- | 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, encode c (get r))])+ ( \kvs -> case lookupField name kvs of+ Just v -> prefix (decode c v)+ Nothing+ | nullable -> prefix (decode c Null)+ | otherwise -> Left ("missing field " <> name)+ )+ where+ schema = maybe id documentSchema d (codecSchema c)+ nullable = case shape (codecSchema c) of+ SNullable _ -> True+ _ -> False+ prefix = either (\e -> Left (name <> ": " <> e)) Right++-- | A field that may be absent.+optional :: Contract a => Text -> Text -> (r -> Maybe a) -> ObjectCodec r (Maybe a)+optional = required++-- | Close an object codec into a contract for a record.+record :: Text -> ObjectCodec a a -> Codec a+record d o =+ Codec+ (documentSchema' (nonEmpty d) (schemaOf (SObject (objectFields o))))+ (Object . objectEncode o)+ ( \case+ Object kvs -> objectDecode o kvs+ v -> mismatch "an object" v+ )++-- ---------------------------------------------------------------------------+-- Sums++-- | One constructor of a sum type.+data Case a = Case+ { caseTag :: Text+ , caseDoc :: Maybe Text+ , caseFields :: [Field]+ , caseEncode :: a -> Maybe [(Text, Value)]+ , caseDecode :: [(Text, Value)] -> Either Text a+ }++-- | 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)+ (objectFields o)+ (\a -> if matches a then Just (objectEncode o a) else Nothing)+ (objectDecode o)++-- | 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)++sumCodec :: Maybe Text -> [Case a] -> Codec a+sumCodec d cases+ | all (null . caseFields) cases =+ Codec+ (documentSchema' d (schemaOf (SEnum [(caseTag c, caseDoc c) | c <- cases])))+ (\a -> maybe Null (String . caseTag) (matching a))+ ( \case+ String t | Just c <- byTag t -> caseDecode c []+ v -> mismatch ("one of " <> T.intercalate ", " (map caseTag cases)) v+ )+ | otherwise =+ Codec+ (documentSchema' d (schemaOf (SSum [Variant (caseTag c) (caseDoc c) (caseFields c) | c <- cases])))+ ( \a -> case [(caseTag c, kvs) | c <- cases, Just kvs <- [caseEncode c a]] of+ (t, kvs) : _ -> Object (("tag", String t) : kvs)+ [] -> Null+ )+ ( \case+ Object kvs+ | Just (String t) <- lookupField "tag" kvs ->+ maybe (Left ("unknown tag " <> t)) (`caseDecode` kvs) (byTag t)+ v -> mismatch "an object with a tag" v+ )+ where+ matching a = find (\c -> isJust (caseEncode c a)) cases+ byTag t = find ((== t) . caseTag) cases++-- ---------------------------------------------------------------------------+-- Adjusting contracts++-- | Describe the whole type.+documented :: Text -> Codec a -> Codec a+documented d c = c {codecSchema = documentSchema d (codecSchema c)}++-- | 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 c = c {codecSchema = s {shape = update (shape s)}}+ where+ s = codecSchema c+ update = \case+ SObject fs | any named fs -> SObject (map describeField fs)+ SSum vs | any (any named . variantFields) vs ->+ SSum [v {variantFields = map describeField (variantFields v)} | v <- vs]+ _ -> error ("Agentic.Contract.field: no field named " <> T.unpack name)+ named f = fieldName f == name+ describeField f+ | named f = f {fieldSchema = documentSchema d (fieldSchema f)}+ | otherwise = f++-- | 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+ ((codecSchema c) {checks = checks (codecSchema c) <> [rule]})+ (encode c)+ ( \v -> do+ a <- decode c v+ if ok a then Right a else Left ("must be " <> rule)+ )++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)++documentSchema' :: Maybe Text -> Schema -> Schema+documentSchema' = maybe id documentSchema++nonEmpty :: Text -> Maybe Text+nonEmpty t = if T.null t then Nothing else Just t++-- ---------------------------------------------------------------------------+-- Generic deriving++-- | 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))++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 (caseFields c)) -> recordFromCase c+ cs -> sumCodec Nothing (map gcase cs)+ where+ named c = c {codecSchema = titled (T.pack (datatypeName (undefined :: M1 D d f ()))) (codecSchema c)}++recordFromCase :: Case a -> Codec a+recordFromCase c =+ Codec+ (schemaOf (SObject (caseFields c)))+ (Object . fromMaybe [] . caseEncode c)+ ( \case+ Object kvs -> caseDecode c kvs+ v -> mismatch "an object" v+ )++data GCase a = GCase {gcase :: Case a, _gcaseBare :: Maybe (Codec a)}++class GCases (f :: Type -> Type) where+ gcases :: [GCase (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 c _) =+ GCase+ c { caseEncode = \y -> unwrap y >>= caseEncode c+ , caseDecode = fmap wrap . caseDecode c+ }+ Nothing++instance (Constructor c, GFields f) => GCases (M1 C c f) where+ gcases =+ [ GCase+ (Case tag Nothing (objectFields o) (Just . objectEncode o) (objectDecode o))+ (mapCodec M1 unM1 <$> gbare @f)+ ]+ where+ tag = T.pack (conName (undefined :: M1 C c f ()))+ o = lmapObject 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))++instance GFields U1 where+ gfields n = (n, pure U1)+ gbare = Nothing++instance (GFields f, GFields g) => GFields (f :*: g) where+ gfields n =+ 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++-- ---------------------------------------------------------------------------+-- Enumerations++data Option a = Option+ { optionValue :: a+ , optionLabel :: Text+ , optionDoc :: Maybe Text+ }++data OptionSet a = OptionSet+ { optionsDoc :: Maybe Text+ , optionList :: [Option a]+ -- ^ 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+ 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))]++-- | 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)++described :: Text -> [Option a] -> OptionSet a+described d = OptionSet (nonEmpty d)++conLabel :: (Generic a, GConName (Rep a)) => a -> Text+conLabel = T.pack . gconName . from++-- | 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+enumeration =+ Codec+ (documentSchema' (optionsDoc set) (schemaOf (SEnum [(optionLabel o, optionDoc o) | o <- opts])))+ (\a -> maybe Null (String . optionLabel) (find ((== a) . optionValue) opts))+ ( \case+ String t | Just o <- find ((== t) . optionLabel) opts -> Right (optionValue o)+ v -> mismatch ("one of " <> T.intercalate ", " (map optionLabel opts)) v+ )+ where+ set = options @a+ opts = optionList set++class GEnum (f :: Type -> Type) where+ genum :: [f p]++instance GEnum f => GEnum (M1 D d f) where+ genum = map M1 genum++instance (GEnum f, GEnum g) => GEnum (f :+: g) where+ genum = map L1 genum <> map R1 genum++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
+ src/Agentic/Core.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Flows: typed, inspectable descriptions of agentic work.+module Agentic.Core+ ( -- * Flows+ Agentic (..)+ , Step (..)+ , Tool (..)+ , Note (..)+ , Instruction (..)+ -- * Steps+ , draft+ , draftWith+ , judge+ , act+ -- * Tools+ , tool+ -- * Structure+ , each+ , repeatUntil+ , note+ , named+ -- * Judgement helpers+ , keep+ , gate+ -- * Re-exports+ , module Control.Arrow+ ) where++import Agentic.Contract (Codec (..), Contract (..))+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 (..))++-- | What a model step is asked to do.+newtype Instruction = Instruction {instructionText :: Text}+ deriving (Eq, Ord, Show)++instance IsString Instruction where+ fromString = Instruction . T.pack++-- | A name, and optionally a description, for a sub-flow. Notes are for whoever+-- is watching the flow, not for the model.+data Note = Note+ { noteName :: Text+ , noteDescription :: Maybe Text+ }+ deriving (Eq, Ord, Show)++-- | The leaves of a flow: the steps that do the work.+data Step m i o where+ Pass :: Step m i i+ -- ^ The input, unchanged: 'id' and 'returnA'.+ Wrap :: (i -> o) -> Step m i o+ -- ^ The input re-wrapped without changing it ('Left', 'Right'), so that+ -- 'Agentic.Describe.describe' can show it as a pass-through.+ 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++-- | A flow from @i@ to @o@ in effect @m@. Build flows from steps with the+-- 'Arrow' combinators; run them with 'Agentic.Interpret.interpret'.+data Agentic m i o where+ Step :: Step m i o -> Agentic m i o+ Seq :: Agentic m a b -> Agentic m b c -> Agentic m a c+ Fanout :: Agentic m a b -> Agentic m a c -> Agentic m a (b, c)+ Split :: Agentic m a b -> Agentic m c d -> Agentic m (a, c) (b, d)+ First :: Agentic m a b -> Agentic m (a, c) (b, c)+ Choose :: Agentic m a c -> Agentic m b c -> Agentic m (Either a b) c+ Each :: Agentic m a b -> Agentic m [a] [b]+ Repeat :: (a -> Bool) -> Agentic m a a -> Agentic m a a+ Noted :: Note -> Agentic m i o -> Agentic m i o++-- | 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++instance Category.Category (Agentic m) where+ id = Step Pass+ g . f = Seq f g++-- The overrides keep the structure visible to 'Agentic.Describe.describe'+-- instead of the defaults' plumbing through @arr swap@.+instance Arrow (Agentic m) where+ arr = Step . Arr+ first = First+ second = Split (Step Pass)+ (***) = Split+ f &&& g = Fanout f g++instance ArrowChoice (Agentic m) where+ left f = Choose (f >>> Step (Wrap Left)) (Step (Wrap Right))+ right f = Choose (Step (Wrap Left)) (f >>> Step (Wrap Right))+ f +++ g = Choose (f >>> Step (Wrap Left)) (g >>> Step (Wrap Right))+ f ||| g = Choose f g++-- | An LLM writes an @o@ from the step's input.+--+-- > draft @Joke "a joke please"+draft :: forall o i m. (Contract i, Contract o, Typeable i, Typeable o) => Instruction -> Agentic m i o+draft = draftWith @o []++-- | An LLM writes an @o@, calling the tools as often as it likes along the way.+draftWith :: forall o i m. (Contract i, Contract o, Typeable i, Typeable o) => [Tool m] -> Instruction -> Agentic m i o+draftWith tools instruction = Step (Draft (titledContract @i) (titledContract @o) instruction tools)++-- | A System One model answers questions about the step's input.+judge :: forall i o m. (Contract i, Typeable i) => Questions o -> Agentic m i o+judge = Step . Judge (titledContract @i)++-- | Plain code with an effect.+act :: (i -> m o) -> Agentic m i o+act = Step . Act++-- | A tool: a name and description for the model, and a flow to run.+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 = c {codecSchema = titled (T.pack (show (typeRep (Proxy @a)))) (codecSchema c)}+ where+ c = contract @a++-- | Map a flow over a list. The runtime may run the items concurrently.+each :: Agentic m a b -> Agentic m [a] [b]+each = Each++-- | Run a flow again and again on its own output until the condition holds.+-- The condition is checked first, so an input that already satisfies it is+-- returned unchanged. The model decides how many rounds it takes; name the+-- loop to say what it waits for:+--+-- > repeatUntil ended nextMove `named` "play until the game ends"+repeatUntil :: (a -> Bool) -> Agentic m a a -> Agentic m a a+repeatUntil = Repeat++-- | Name and describe a sub-flow.+note :: Text -> Text -> Agentic m i o -> Agentic m i o+note name description = Noted (Note name (if T.null description then Nothing else Just description))++-- | Name a flow. Written infix, it names exactly the expression before it,+-- because it binds as tightly as function application:+--+-- > draft @[Creature] "Name 10 prehistoric creatures"+-- > >>> arr (partition clearDinosaur) `named` "keep the clear dinosaurs"+-- > >>> ...+--+-- Bracket a larger sub-flow to name all of it.+named :: Agentic m i o -> Text -> Agentic m i o+f `named` name = Noted (Note name Nothing) f++infixl 9 `named`++-- | Keep the items where the probability of yes is at least @p@.+keep :: (Contract i, Typeable i) => Probability -> Questions YesNo -> Agentic m [i] [i]+keep p q =+ note ("keep " <> T.pack (show p)) "" $+ each (returnA &&& judge q)+ >>> arr (map fst . filter ((>= p) . yes . snd))++-- | Send the input 'Right' if the probability of yes is at least @p@, and+-- 'Left' otherwise.+gate :: (Contract i, Typeable i) => Probability -> Questions YesNo -> Agentic m i (Either i i)+gate p q =+ note ("gate " <> T.pack (show p)) "" $+ (returnA &&& judge q)+ >>> arr (\(x, a) -> if yes a >= p then Right x else Left x)
+ src/Agentic/Describe.hs view
@@ -0,0 +1,492 @@+-- | Looking at a flow without running it.+module Agentic.Describe+ ( describe+ , Description (..)+ , StepInfo (..)+ , ToolInfo (..)+ , renderTree+ , mermaid+ , dot+ , flowGraph+ , FlowGraph (..)+ , Item (..)+ , NodeKind (..)+ , Edge (..)+ , EdgeStyle (..)+ , toValue+ ) where++import Agentic.Contract (Codec (..))+import Agentic.Core+import Agentic.Questions (QuestionSpec (..), Questions (..))+import Agentic.Schema (Schema, typeLabel)+import Agentic.Value (Value (..))+import Data.List (mapAccumL)+import Data.Text (Text)+import qualified Data.Text as T++data Description+ = Leaf StepInfo+ | Sequence [Description]+ -- ^ @a >>> b >>> c@, flattened.+ | Together [Description]+ -- ^ @a &&& b &&& c@, flattened.+ | Halves Description Description+ -- ^ @a *** b@: one flow on each half of a pair.+ | Branch Description Description+ | ForEach Description+ | Repeated Description+ -- ^ @repeatUntil@: run again on its own output until a condition holds.+ | Annotated Note Description++data StepInfo+ = Identity+ -- ^ The input, unchanged ('returnA').+ | Glue+ -- ^ @arr@: a pure function.+ | Effect+ -- ^ @act@: plain code with an effect.+ | DraftInfo+ { draftInstruction :: Instruction+ , draftInput :: Schema+ , draftOutput :: Schema+ , draftTools :: [ToolInfo]+ }+ | JudgeInfo+ { judgeState :: Schema+ , judgeQuestions :: [QuestionSpec]+ }++data ToolInfo = ToolInfo+ { infoName :: Text+ , infoDescription :: Text+ , infoInput :: Schema+ , infoOutput :: Schema+ , infoBody :: Description+ }++-- | Describe a flow. This never runs anything.+describe :: Agentic m i o -> Description+describe = \case+ Step s -> Leaf (stepInfo s)+ Seq f g -> Sequence (sequenced (describe f) <> sequenced (describe g))+ Fanout f g -> Together (together (describe f) <> together (describe g))+ Split f g -> Halves (describe f) (describe g)+ First f -> Halves (describe f) (Leaf Identity)+ Choose f g -> Branch (describe f) (describe g)+ Each f -> ForEach (describe f)+ Repeat _ f -> Repeated (describe f)+ Noted n f -> Annotated n (describe f)+ where+ sequenced = \case+ Sequence ds -> ds+ d -> [d]+ together = \case+ Together ds -> ds+ d -> [d]++stepInfo :: Step m i o -> StepInfo+stepInfo = \case+ Pass -> Identity+ Wrap _ -> Identity+ Arr _ -> Glue+ Act _ -> Effect+ Draft input out instruction tools ->+ DraftInfo instruction (codecSchema input) (codecSchema out) (map toolInfo tools)+ Judge input qs -> JudgeInfo (codecSchema input) (specs qs)++toolInfo :: Tool m -> ToolInfo+toolInfo (Tool name description input out body) =+ ToolInfo name description (codecSchema input) (codecSchema out) (describe body)++-- ---------------------------------------------------------------------------+-- The tree view++instance Show Description where+ show = T.unpack . renderTree++data Tree = Node Text [Tree]++-- | The tree view. Each tool's body is expanded the first time the tool+-- appears. Unnamed glue between steps is hidden, but a branch is never hidden:+-- inside @&&&@, @***@ and @|||@ it shows as @arr@ (or @pass@ for 'returnA'), and+-- a pass-through beside a step shows as "keeping its input".+renderTree :: Description -> Text+renderTree = T.intercalate "\n" . concatMap (draw "" "") . snd . trees []++-- | Convert to trees, threading the names of tools already expanded.+trees :: [Text] -> Description -> ([Text], [Tree])+trees seen = \case+ Leaf Identity -> (seen, [])+ Leaf Glue -> (seen, [])+ Leaf info -> leaf Nothing info+ Sequence ds -> 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+ (seen', [Node t cs]) -> (seen', [Node (t <> keeping) cs])+ (seen', ts) -> (seen', [Node ("together" <> keeping) ts])+ Halves l r ->+ let (seen1, ls) = branch seen l+ (seen2, rs) = branch seen1 r+ in (seen2, [Node "both halves" [labelled "first" ls, labelled "second" rs]])+ Branch l r ->+ let (seen1, ls) = branch seen l+ (seen2, rs) = branch seen1 r+ in (seen2, [Node "branch" [labelled "left" ls, labelled "right" rs]])+ Repeated d -> case branch seen d of+ (seen', [Node "together" ts]) -> (seen', [Node "repeatUntil" ts])+ (seen', ts) -> (seen', [Node "repeatUntil" ts])+ ForEach d -> case branch seen d of+ (seen', [Node "together" ts]) -> (seen', [Node "each" ts])+ (seen', ts) -> (seen', [Node "each" ts])+ Annotated n (Leaf info) | not (passes (Leaf info)) -> leaf (Just (noteName n)) info+ Annotated n d -> case trees seen d of+ (seen', [Node t cs]) -> (seen', [Node (noteName n <> " " <> t) cs])+ (seen', []) -> (seen', [Node (noteName n) []])+ (seen', ts) -> (seen', [Node (noteName n) ts])+ where+ -- A step: what kind it is, then its name, then the details.+ leaf name info =+ let (seen', toolTrees) = case info of+ DraftInfo _ _ _ tools -> mapAccumL toolTree seen tools+ _ -> (seen, [])+ in (seen', [Node (T.intercalate " " (stepLines name info)) toolTrees])+ -- A branch of @&&&@ that's several steps in a row is grouped, so its steps+ -- don't read as more parallel branches.+ parallel s d = case branch s d of+ (s', ts@(_ : _ : _)) -> (s', [Node "in order" ts])+ r -> r+ -- A branch always shows, even when it's only glue.+ branch s d = case trees s d of+ (s', []) -> (s', [Node (if passes d then "pass" else "arr") []])+ r -> r+ toolTree s t+ | infoName t `elem` s = (s, Node ("tool " <> infoName t <> " (see above)") [])+ | otherwise = case trees (infoName t : s) (infoBody t) of+ (s', [Node body cs]) -> (s', Node ("tool " <> infoName t <> " " <> body) cs)+ (s', ts) -> (s', Node ("tool " <> infoName t) ts)+ labelled l = \case+ [Node t cs] -> Node (l <> " → " <> t) cs+ [] -> Node (l <> " → pass") []+ ts -> Node l ts++-- | Does this part of a flow only pass its input through?+passes :: Description -> Bool+passes = \case+ Leaf Identity -> True+ Sequence ds -> all passes ds+ Annotated _ d -> passes d+ _ -> False++questionText :: QuestionSpec -> Text+questionText = \case+ AskYesNo q -> "yes/no " <> quoted q+ AskChoice q opts -> "choice of " <> T.pack (show (length opts)) <> " " <> quoted q+ AskScore q levels -> "score on " <> T.pack (show (length levels)) <> " levels " <> quoted q++quoted :: Text -> Text+quoted t = "\"" <> t <> "\""++draw :: Text -> Text -> Tree -> [Text]+draw lead childLead (Node t cs) = (lead <> t) : go cs+ where+ go = \case+ [] -> []+ [c] -> draw (childLead <> "└─ ") (childLead <> " ") c+ c : rest -> draw (childLead <> "├─ ") (childLead <> "│ ") c <> go rest++-- ---------------------------------------------------------------------------+-- Mermaid++-- | How data moves through a flow, as a graph: steps joined in order; @&&&@,+-- @***@ and @|||@ forking into their branches and joining again at the next+-- step, with a pass-through drawn as an edge straight to the join; @each@,+-- @repeatUntil@ and named sub-flows as boxes; tools hanging off their draft.+-- 'mermaid' and 'dot' render it.+data FlowGraph = FlowGraph+ { graphItems :: [Item]+ , graphEdges :: [Edge]+ }++-- | A node, or a box of items.+data Item+ = ItemNode Text NodeKind [Text]+ -- ^ An id, what kind of node it is, and its label's lines.+ | ItemBox Text [Text] [Item]+ -- ^ An id, its label's lines, and what's inside.++data NodeKind = Terminal | StepNode | ToolNode++data Edge = Edge+ { edgeFrom :: Text+ , edgeTo :: Text+ -- ^ A node, or a box's id.+ , edgeLabel :: Maybe Text+ , edgeStyle :: EdgeStyle+ }++data EdgeStyle = Flow | Uses | Again++-- | The flow's graph, from @input@ to @output@.+flowGraph :: Description -> FlowGraph+flowGraph d = case runBuild flow (BuildState 0 [[]] []) of+ (_, BuildState _ open edges) -> FlowGraph (reverse (concat open)) (reverse edges)+ where+ flow = do+ item (ItemNode "input" Terminal ["input"])+ exits <- build InSequence [("input", Nothing)] d+ item (ItemNode "output" Terminal ["output"])+ connect exits "output"++-- | Where a description sits: unnamed glue between steps is plumbing, but a+-- branch that's only glue is still a branch.+data Context = InSequence | InBranch++-- | Nodes the next step connects from, each with an optional edge label.+type From = [(Text, Maybe Text)]++-- | A counter for ids, the items of each open box (innermost first), and edges.+data BuildState = BuildState Int [[Item]] [Edge]++newtype Build a = Build {runBuild :: BuildState -> (a, BuildState)}++instance Functor Build where+ fmap f (Build g) = Build (\s -> let (a, s') = g s in (f a, s'))++instance Applicative Build where+ pure a = Build (\s -> (a, s))+ Build f <*> Build g = Build (\s -> let (h, s1) = f s; (a, s2) = g s1 in (h a, s2))++instance Monad Build where+ Build g >>= k = Build (\s -> let (a, s1) = g s in runBuild (k a) s1)++fresh :: Build Text+fresh = Build (\(BuildState n open es) -> ("n" <> T.pack (show n), BuildState (n + 1) open es))++item :: Item -> Build ()+item i = Build $ \case+ BuildState n (current : outer) es -> ((), BuildState n ((i : current) : outer) es)+ BuildState n [] es -> ((), BuildState n [[i]] es)++edge :: Edge -> Build ()+edge e = Build (\(BuildState n open es) -> ((), BuildState n open (e : es)))++edgeCount :: Build Int+edgeCount = Build (\s@(BuildState _ _ es) -> (length es, s))++-- | The nodes that edges added since @before@ lead into from these sources.+entriesSince :: Int -> [Text] -> Build [Text]+entriesSince before sources = Build $ \s@(BuildState _ _ es) ->+ let new = reverse (take (length es - before) es)+ in (nubOrdered [edgeTo e | e <- new, edgeFrom e `elem` sources], s)+ where+ nubOrdered = foldr (\x acc -> x : filter (/= x) acc) []++connect :: From -> Text -> Build ()+connect from to = mapM_ (\(f, l) -> edge (Edge f to l Flow)) from++node :: From -> [Text] -> Build From+node from label = do+ n <- fresh+ item (ItemNode n StepNode label)+ connect from n+ pure [(n, Nothing)]++box :: [Text] -> Build a -> Build (Text, a)+box label inside = do+ b <- fresh+ Build (\(BuildState n open es) -> ((), BuildState n ([] : open) es))+ a <- inside+ Build $ \case+ BuildState n (contents : parent : outer) es -> ((), BuildState n ((ItemBox b label (reverse contents) : parent) : outer) es)+ s -> ((), s)+ pure (b, a)++build :: Context -> From -> Description -> Build From+build context from = \case+ Leaf Identity -> pure from+ Leaf Glue -> case context of+ InSequence -> pure from+ InBranch -> node from ["arr"]+ Leaf info -> step Nothing info+ Sequence ds -> chain from ds+ Together ds -> concat <$> mapM (build InBranch from) ds+ Halves l r -> (<>) <$> build InBranch (labelled "first") l <*> build InBranch (labelled "second") r+ Branch l r -> (<>) <$> build InBranch (labelled "left") l <*> build InBranch (labelled "right") r+ ForEach f -> snd <$> box ["each"] (build InSequence from f)+ -- "Again" goes back to where the body starts: the steps the loop's input+ -- flows into. If the body has none, it goes to the box.+ Repeated f -> do+ before <- edgeCount+ (b, exits) <- box ["repeatUntil"] (build InSequence from f)+ entries <- entriesSince before (map fst from)+ let targets = if null entries then [b] else entries+ mapM_ (\(e, _) -> mapM_ (\t -> edge (Edge e t (Just "again") Again)) targets) exits+ pure exits+ Annotated n (Leaf info) | not (passes (Leaf info)) -> step (Just n) info+ Annotated n f -> snd <$> box (noteName n : maybe [] pure (noteDescription n)) (build InSequence from f)+ where+ labelled l = [(f, Just l) | (f, _) <- from]+ chain acc = \case+ [] -> pure acc+ x : xs -> build InSequence acc x >>= (`chain` xs)+ -- A step's node, labelled by 'stepLines', with any tools hanging off it.+ -- In a diagram, a named step's description goes under its name.+ step note' info = do+ let lines'' = case (stepLines (noteName <$> note') info, note' >>= noteDescription) of+ (kind : name : details, Just description) -> kind : name : description : details+ (ls, _) -> ls+ exits <- node from lines''+ case info of+ DraftInfo _ _ _ tools ->+ mapM_+ ( \t -> do+ n <- fresh+ item (ItemNode n ToolNode ["tool " <> infoName t])+ mapM_ (\(e, _) -> edge (Edge e n Nothing Uses)) exits+ )+ tools+ _ -> pure ()+ pure exits++-- | How a step is labelled, everywhere: what kind of step it is, then its name+-- if it has one, then its details (an instruction, or questions).+stepLines :: Maybe Text -> StepInfo -> [Text]+stepLines name info = kind : maybe [] pure name <> details+ where+ (kind, details) = case info of+ Identity -> ("pass", [])+ Glue -> ("arr", [])+ Effect -> ("act", [])+ DraftInfo instruction _ out _ -> ("draft @" <> typeLabel out, [quoted (instructionText instruction)])+ JudgeInfo _ [q] -> ("judge", [questionText q])+ JudgeInfo _ qs -> ("judge " <> T.pack (show (length qs)) <> " questions in one request", map questionText qs)++-- | A Mermaid flowchart of the flow's graph.+mermaid :: Description -> Text+mermaid d = T.unlines ("flowchart TD" : concatMap (items' " ") is <> map edge' es)+ where+ FlowGraph is es = flowGraph d+ items' indent = \case+ ItemNode i kind ls -> [indent <> i <> shape kind (T.intercalate "<br/>" (map escape ls))]+ ItemBox i ls inside -> [indent <> "subgraph " <> i <> "[\"" <> T.intercalate "<br/>" (map escape ls) <> "\"]"] <> concatMap (items' (indent <> " ")) inside <> [indent <> "end"]+ shape kind l = case kind of+ Terminal -> "([\"" <> l <> "\"])"+ StepNode -> "[\"" <> l <> "\"]"+ ToolNode -> "[/\"" <> l <> "\"/]"+ edge' (Edge f t l style) = " " <> f <> arrow style <> maybe "" (\x -> "|" <> escape x <> "|") l <> " " <> t+ arrow = \case+ Flow -> " -->"+ Uses -> " -.-"+ Again -> " -.->"+ escape = T.replace "\"" "#quot;"++-- | A Graphviz DOT digraph of the flow's graph. Render it with, for example,+-- @dot -Tsvg@.+dot :: Description -> Text+dot d =+ T.unlines $+ ["digraph flow {", " compound=true;", " node [shape=box, style=rounded, fontname=\"Helvetica\"];", " edge [fontname=\"Helvetica\"];"]+ <> concatMap (items' " ") is+ <> map edge' es+ <> ["}"]+ where+ FlowGraph is es = flowGraph d+ items' indent = \case+ ItemNode i kind ls -> [indent <> i <> " [label=\"" <> T.intercalate "\\n" (map inner ls) <> "\"" <> shape kind <> "];"]+ ItemBox i ls inside -> [indent <> "subgraph cluster_" <> i <> " {", indent <> " label=\"" <> T.intercalate "\\n" (map inner ls) <> "\";", indent <> " style=rounded;"] <> concatMap (items' (indent <> " ")) inside <> [indent <> "}"]+ shape = \case+ Terminal -> ", shape=oval"+ StepNode -> ""+ ToolNode -> ", shape=parallelogram, style=\"\""+ -- An edge into a box points at the box's first node, clipped to the box.+ edge' (Edge f t l style) =+ let (target, attrs) = case firstNode t is of+ Just n+ | inBox t f is -> (n, [])+ | otherwise -> (n, ["lhead=cluster_" <> t])+ Nothing -> (t, [])+ extra = maybe [] (\x -> ["label=" <> str x]) l <> attrs <> styleOf style+ in " " <> f <> " -> " <> target <> (if null extra then "" else " [" <> T.intercalate ", " extra <> "]") <> ";"+ styleOf = \case+ Flow -> []+ Uses -> ["style=dotted", "arrowhead=none"]+ Again -> ["style=dashed"]+ str t = "\"" <> inner t <> "\""+ inner = T.concatMap (\case '"' -> "\\\""; '\\' -> "\\\\"; c -> T.singleton c)++-- | Is the node with this id inside the box with that id?+inBox :: Text -> Text -> [Item] -> Bool+inBox b n = any within+ where+ within = \case+ ItemBox i _ inside+ | i == b -> any contains inside+ | otherwise -> any within inside+ ItemNode {} -> False+ contains = \case+ ItemNode i _ _ -> i == n+ ItemBox _ _ inside -> any contains inside++-- | The first node inside the box with this id, if the id is a box's. Only an+-- edge into an empty loop needs it.+firstNode :: Text -> [Item] -> Maybe Text+firstNode b = go+ where+ go = \case+ [] -> Nothing+ ItemBox i _ inside : rest+ | i == b -> first inside+ | otherwise -> maybe (go rest) Just (go inside)+ ItemNode {} : rest -> go rest+ first = \case+ ItemNode i _ _ : _ -> Just i+ ItemBox _ _ inside : rest -> maybe (first rest) Just (first inside)+ [] -> Nothing++-- ---------------------------------------------------------------------------+-- JSON++-- | The description as a JSON-shaped value, for UIs and other agents.+toValue :: Description -> Value+toValue = \case+ Leaf info -> leaf info+ Sequence ds -> node "sequence" [("steps", Array (map toValue ds))]+ Together ds -> node "together" [("steps", Array (map toValue ds))]+ Halves l r -> node "halves" [("first", toValue l), ("second", toValue r)]+ Branch l r -> node "branch" [("left", toValue l), ("right", toValue r)]+ ForEach d -> node "each" [("step", toValue d)]+ Repeated d -> node "repeat" [("step", toValue d)]+ Annotated n d ->+ node "note" $+ [("name", String (noteName n))]+ <> maybe [] (\t -> [("description", String t)]) (noteDescription n)+ <> [("step", toValue d)]+ where+ node kind fields = Object (("kind", String kind) : fields)+ leaf = \case+ Identity -> node "pass" []+ Glue -> node "arr" []+ Effect -> node "act" []+ DraftInfo instruction input out tools ->+ node+ "draft"+ [ ("instruction", String (instructionText instruction))+ , ("input", String (typeLabel input))+ , ("output", String (typeLabel out))+ , ("tools", Array (map tool tools))+ ]+ JudgeInfo input qs ->+ node "judge" [("state", String (typeLabel input)), ("questions", Array (map question qs))]+ tool t =+ Object+ [ ("name", String (infoName t))+ , ("description", String (infoDescription t))+ , ("input", String (typeLabel (infoInput t)))+ , ("output", String (typeLabel (infoOutput t)))+ ]+ 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])]
+ src/Agentic/Interpret.hs view
@@ -0,0 +1,97 @@+-- | Running flows.+module Agentic.Interpret+ ( interpret+ ) where++import Agentic.Contract (Codec (..))+import Agentic.Core+import Agentic.Questions (JudgeRequest (..), Questions (..), decodeAnswers)+import Agentic.Runtime+import Data.List (find)++-- | 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 <- parallel 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 <- parallel 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 -> parallel 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 = observe rt . 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)+ Arr f -> pure (f x)+ Act f -> emit path Acted >> f x+ Judge input qs+ | null (specs qs) -> answered (decodeAnswers qs [])+ | otherwise -> do+ let request = JudgeRequest (encode input x) (specs qs)+ answers <- askSystemOne (systemOne rt) request+ emit path (Judged request answers)+ answered (decodeAnswers qs answers)+ Draft input out instruction tools -> do+ let conversation =+ Conversation+ { path = path+ , instruction = instruction+ , state = encode input x+ , stateSchema = codecSchema input+ , tools = map toolSpec tools+ , output = codecSchema out+ , history = []+ }+ emit path (Drafting conversation)+ let loop past = do+ turn <- askSystemTwo (systemTwo rt) conversation {history = past}+ emit path (Turned turn)+ case action turn of+ Respond v -> case decode out v of+ Right b -> pure b+ Left problem -> do+ emit path (OutputRejected problem)+ loop (past <> [Rejected (raw turn) problem])+ CallTools calls -> do+ results <- parallel rt (map (runTool path tools) calls)+ loop (past <> [Called (raw turn) (zip (map callId calls) results)])+ loop []+ where+ answered = either (failure rt . MalformedAnswers) pure++ runTool :: [Note] -> [Tool m] -> ToolCall -> m ToolResult+ runTool path tools call = do+ emit path (ToolCalled call)+ result <- case find ((== callName call) . nameOf) tools of+ Nothing -> pure (ToolFailed ("there is no tool named " <> callName call))+ Just (Tool name _ input out body) -> case decode input (callInput call) of+ Left problem -> pure (ToolFailed ("invalid input: " <> problem))+ Right i -> ToolOk . encode out <$> go (path <> [Note name Nothing]) body i+ emit path (ToolReturned (callId call) result)+ pure result+ where+ nameOf (Tool name _ _ _ _) = name++toolSpec :: Tool m -> ToolSpec+toolSpec (Tool name description input _ _) = ToolSpec name description (codecSchema input)
+ src/Agentic/Questions.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Questions for a System One model such as Jev. Following Jev's terms, a step+-- asks t'Questions' about its input, the /state/.+module Agentic.Questions+ ( -- * Questions+ Questions (..)+ , yesNo+ , choice+ , score+ -- * Answers+ , Probability+ , probability+ , fromBasisPoints+ , basisPoints+ , YesNo (..)+ , Choice (..)+ , Score (..)+ -- * Wire types+ , QuestionSpec (..)+ , Answer (..)+ , JudgeRequest (..)+ , decodeAnswers+ ) where++import Agentic.Contract (Contract (..), Option (..), OptionSet (..), Options (..), mapCodec, record, required)+import Agentic.Value (Value (..))+import Data.List (find)+import Data.Text (Text)+import qualified Data.Text as T++-- ---------------------------------------------------------------------------+-- Probabilities++-- | A probability, held as basis points (0–10000) so that results replay and+-- compare exactly. Write literals directly: @0.9 :: Probability@.+newtype Probability = Probability Int+ deriving (Eq, Ord)++instance Show Probability where+ show p = show (probability p)++instance Num Probability where+ Probability a + Probability b = clamp (a + b)+ Probability a - Probability b = clamp (a - b)+ Probability a * Probability b = clamp ((a * b) `div` 10000)+ abs = id+ signum (Probability a) = Probability (if a > 0 then 10000 else 0)+ fromInteger n = clamp (fromInteger n * 10000)++instance Fractional Probability where+ fromRational r = clamp (round (r * 10000))+ Probability a / Probability b = clamp ((a * 10000) `div` max 1 b)++clamp :: Int -> Probability+clamp = Probability . max 0 . min 10000++probability :: Probability -> Double+probability (Probability bp) = fromIntegral bp / 10000++-- | Convert a provider's probability, rounding once (half to even).+fromBasisPoints :: Double -> Probability+fromBasisPoints d = clamp (round (d * 10000))++basisPoints :: Probability -> Int+basisPoints (Probability bp) = bp++-- ---------------------------------------------------------------------------+-- Answers++-- | Jev's Noul: the probability that the answer is yes.+newtype YesNo = YesNo {yes :: Probability}+ deriving (Eq, Show)++data Choice a = Choice+ { chosen :: a+ , choiceProbabilities :: [(a, Probability)]+ , choiceConfidence :: Probability+ }+ deriving (Eq, Show)++data Score a = Score+ { position :: Double+ -- ^ The probability-weighted position, from 0 (the first option) upwards.+ , scoreProbabilities :: [(a, Probability)]+ , scoreConfidence :: Probability+ }+ deriving (Eq, Show)++-- Answers have contracts, so a judgement can be a tool's output.++instance Contract Probability where+ contract = mapCodec fromBasisPoints probability (contract @Double)++instance Contract YesNo where+ contract = record "A yes/no judgement" (YesNo <$> required "yes" "The probability that the answer is yes" yes)++instance Contract a => Contract (Choice a) where+ contract =+ record "A choice between options" $+ Choice+ <$> required "chosen" "The most likely option" chosen+ <*> required "probabilities" "Each option's probability" choiceProbabilities+ <*> required "confidence" "How concentrated the probabilities are" choiceConfidence++instance Contract a => Contract (Score a) where+ contract =+ record "A position on ordered levels" $+ Score+ <$> required "position" "The probability-weighted position, from 0 upwards" position+ <*> required "probabilities" "Each level's probability" scoreProbabilities+ <*> required "confidence" "How concentrated the probabilities are" scoreConfidence++-- ---------------------------------------------------------------------------+-- Wire types++data QuestionSpec+ = AskYesNo Text+ | AskChoice Text [(Text, Maybe Text)]+ -- ^ Option labels with their descriptions.+ | AskScore Text [(Text, Maybe Text)]+ -- ^ Levels in order, lowest first.+ 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.+ deriving (Eq, Show)++-- | What a System One provider receives: the encoded state and the questions.+data JudgeRequest = JudgeRequest+ { requestState :: Value+ , requestQuestions :: [QuestionSpec]+ }+ deriving (Eq, Ord, Show)++-- ---------------------------------------------------------------------------+-- Questions++-- | One or more questions about the same state, sent as one request. Combine+-- them applicatively:+--+-- > judge (Review <$> funny <*> groan)+data Questions a = Questions+ { specs :: [QuestionSpec]+ , decoder :: [Answer] -> Either Text a+ }++instance Functor Questions where+ fmap f q = q {decoder = fmap f . decoder q}++instance Applicative Questions where+ pure x = Questions [] (\case [] -> Right x; _ -> Left "too many answers")+ Questions l dl <*> Questions r dr = Questions (l <> r) $ \answers ->+ let (before, after) = splitAt (length l) answers+ in dl before <*> dr after++decodeAnswers :: Questions a -> [Answer] -> Either Text a+decodeAnswers = decoder++single :: QuestionSpec -> (Answer -> Either Text a) -> Questions a+single spec decode = Questions [spec] $ \case+ [answer] -> decode answer+ answers -> Left ("expected one answer, got " <> T.pack (show (length answers)))++-- | Jev's Noul primitive: how likely is it that the answer is yes?+yesNo :: Text -> Questions YesNo+yesNo q = single (AskYesNo q) $ \case+ YesNoAnswer p -> Right (YesNo p)+ other -> Left ("expected a yes/no answer, got " <> T.pack (show other))++-- | Pick one of an 'Options' type's values.+choice :: forall a. Options a => Text -> Questions (Choice a)+choice q = single (AskChoice q (labels opts)) $ \case+ 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 = optionList (options @a)++-- | Place the state on an 'Options' type's levels, lowest first.+score :: forall a. Options a => Text -> Questions (Score a)+score q = single (AskScore q (labels opts)) $ \case+ 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 = optionList (options @a)+ byIndex i = case drop i opts of+ o : _ | i >= 0 -> Right (optionValue o)+ _ -> Left ("no level " <> T.pack (show i))++labels :: [Option a] -> [(Text, Maybe Text)]+labels = map (\o -> (optionLabel o, optionDoc o))++byLabel :: [Option a] -> Text -> Either Text a+byLabel opts l = maybe (Left ("unknown option " <> l)) (Right . optionValue) (find ((== l) . optionLabel) opts)
+ src/Agentic/Runtime.hs view
@@ -0,0 +1,187 @@+-- | The runtime: the one connection between a flow and the outside world.+module Agentic.Runtime+ ( -- * Runtime+ Runtime (..)+ , runtime+ , runtimeWith+ , SystemOne (..)+ , SystemTwo (..)+ , ProvidesSystemOne (..)+ , ProvidesSystemTwo (..)+ , withSystemOne+ , withSystemTwo+ -- * Modifiers+ , observing+ , capped+ -- * System Two turns+ , Conversation (..)+ , ToolSpec (..)+ , Exchange (..)+ , ToolResult (..)+ , Turn (..)+ , Raw (..)+ , Action (..)+ , ToolCall (..)+ -- * Events and errors+ , Event (..)+ , Happened (..)+ , FlowError (..)+ ) where++import Agentic.Core (Instruction, Note)+import Agentic.Questions (Answer, JudgeRequest)+import Agentic.Schema (Schema)+import Agentic.Value (Value (..))+import Control.Exception (Exception, throwIO)+import Data.Text (Text)++-- ---------------------------------------------------------------------------+-- System Two turns++-- | Everything a System Two provider needs to take one turn of a step.+data Conversation = Conversation+ { path :: [Note]+ -- ^ Where this step is in the flow.+ , instruction :: Instruction+ , state :: Value+ -- ^ The step's input, encoded by its contract.+ , stateSchema :: Schema+ , tools :: [ToolSpec]+ , output :: Schema+ -- ^ The schema of the step's result.+ , history :: [Exchange]+ -- ^ Earlier turns of this step, oldest first. Append-only.+ }+ deriving (Eq, Show)++data ToolSpec = ToolSpec+ { specName :: Text+ , specDescription :: Text+ , specInput :: Schema+ }+ deriving (Eq, Show)++data Exchange+ = Called Raw [(Text, ToolResult)]+ -- ^ The model's turn, and the result of each tool call by call id.+ | Rejected Raw Text+ -- ^ The model's final value failed its contract's checks.+ deriving (Eq, Show)++data ToolResult = ToolOk Value | ToolFailed Text+ deriving (Eq, Show)++data Turn = Turn+ { raw :: Raw+ , action :: Action+ }+ deriving (Eq, Show)++-- | A provider's own message for a turn. The core stores it and hands it back+-- unchanged; only the provider looks inside.+newtype Raw = Raw Value+ deriving (Eq, Show)++data Action+ = CallTools [ToolCall]+ | Respond Value+ deriving (Eq, Show)++data ToolCall = ToolCall+ { callId :: Text+ , callName :: Text+ , callInput :: Value+ }+ deriving (Eq, Show)++-- ---------------------------------------------------------------------------+-- Events and errors++data Event = Event+ { eventPath :: [Note]+ , happened :: Happened+ }+ deriving (Show)++data Happened+ = Drafting Conversation+ | Turned Turn+ | ToolCalled ToolCall+ | ToolReturned Text ToolResult+ | OutputRejected Text+ | Judged JudgeRequest [Answer]+ | Acted+ deriving (Show)++-- | Errors the core raises itself. Provider errors are the provider's own.+data FlowError+ = NoSystemOne+ | NoSystemTwo+ | MalformedAnswers Text+ | TurnLimit Int+ deriving (Eq, Show)++instance Exception FlowError++-- ---------------------------------------------------------------------------+-- Runtime++-- | Fast, typed judgements (Jev, or an LLM standing in).+newtype SystemOne m = SystemOne {askSystemOne :: JudgeRequest -> m [Answer]}++-- | One LLM turn.+newtype SystemTwo m = SystemTwo {askSystemTwo :: Conversation -> m Turn}++-- | Everything a flow needs from the outside world: its two kinds of model,+-- how to run independent work, where events go, and how to raise errors.+data Runtime m = Runtime+ { systemOne :: SystemOne m+ , systemTwo :: SystemTwo m+ , parallel :: forall a. [m a] -> m [a]+ -- ^ Runs independent work: 'Agentic.Core.each', 'Control.Arrow.&&&', parallel tool calls.+ , observe :: Event -> m ()+ , failure :: forall a. FlowError -> m a+ }++-- | A runtime in IO with no providers: it runs things one after another,+-- observes nothing, and throws 'FlowError's.+runtime :: Runtime IO+runtime = runtimeWith throwIO++-- | A runtime in any monad, given how it raises errors.+runtimeWith :: Monad m => (forall a. FlowError -> m a) -> Runtime m+runtimeWith raise =+ Runtime+ { systemOne = SystemOne (const (raise NoSystemOne))+ , systemTwo = SystemTwo (const (raise NoSystemTwo))+ , parallel = sequence+ , observe = const (pure ())+ , failure = raise+ }++class ProvidesSystemOne p where+ toSystemOne :: p -> IO (SystemOne IO)++class ProvidesSystemTwo p where+ toSystemTwo :: p -> IO (SystemTwo IO)++withSystemOne :: ProvidesSystemOne p => p -> Runtime IO -> IO (Runtime IO)+withSystemOne p rt = (\s -> rt {systemOne = s}) <$> toSystemOne p++withSystemTwo :: ProvidesSystemTwo p => p -> Runtime IO -> IO (Runtime IO)+withSystemTwo p rt = (\s -> rt {systemTwo = s}) <$> toSystemTwo p++-- ---------------------------------------------------------------------------+-- Modifiers++-- | Also send every event to @f@.+observing :: Applicative m => (Event -> m ()) -> Runtime m -> Runtime m+observing f rt = rt {observe = \e -> observe rt e *> f e}++-- | Fail a step that takes more than @n@ turns.+capped :: Int -> Runtime m -> Runtime m+capped n rt = rt {systemTwo = SystemTwo turn}+ where+ turn c+ | length (history c) >= n = failure rt (TurnLimit n)+ | otherwise = askSystemTwo (systemTwo rt) c
+ src/Agentic/Schema.hs view
@@ -0,0 +1,86 @@+-- | The schema of a 'Agentic.Contract.Contract'. It's richer than any one+-- provider's wire format; provider packages lower it to what they accept.+module Agentic.Schema+ ( Schema (..)+ , Shape (..)+ , Field (..)+ , Variant (..)+ , Format (..)+ , schemaOf+ , documentSchema+ , typeLabel+ , titled+ ) where++import Data.Text (Text)++data Schema = Schema+ { title :: Maybe Text+ -- ^ The type's name, e.g. @Joke@. Providers use it to name schemas.+ , doc :: Maybe Text+ , checks :: [Text]+ -- ^ Constraints the wire schemas can't express, stated for the model and+ -- checked locally.+ , shape :: Shape+ }+ deriving (Eq, Show)++data Shape+ = SObject [Field]+ | SSum [Variant]+ -- ^ A tagged union: each variant is an object with a @tag@ field.+ | SEnum [(Text, Maybe Text)]+ -- ^ A choice of labels, each with an optional description.+ | SArray Schema+ | SNullable Schema+ | SString (Maybe Format)+ | SInteger+ | SNumber+ | SBool+ | SNull+ deriving (Eq, Show)++data Field = Field+ { fieldName :: Text+ , fieldSchema :: Schema+ , fieldRequired :: Bool+ }+ deriving (Eq, Show)++data Variant = Variant+ { variantTag :: Text+ , variantDoc :: Maybe Text+ , variantFields :: [Field]+ }+ deriving (Eq, Show)++data Format = DateTime | Date | Email | Uri | Uuid+ deriving (Eq, Show)++schemaOf :: Shape -> Schema+schemaOf = Schema Nothing Nothing []++documentSchema :: Text -> Schema -> Schema+documentSchema d s = s {doc = Just d}++-- | Name the schema's type, unless it already has a name.+titled :: Text -> Schema -> Schema+titled t s = s {title = maybe (Just t) Just (title s)}++-- | A short label for display, e.g. in 'Agentic.Describe.describe'.+typeLabel :: Schema -> Text+typeLabel s = maybe (structural (shape s)) id (title s)+ where+ structural = \case+ SObject _ -> "object"+ SSum [] -> "sum"+ SSum vs -> "sum of " <> joinTags (map variantTag vs)+ SEnum ls -> "one of " <> joinTags (map fst ls)+ SArray inner -> "[" <> typeLabel inner <> "]"+ SNullable inner -> typeLabel inner <> "?"+ SString _ -> "text"+ SInteger -> "integer"+ SNumber -> "number"+ SBool -> "bool"+ SNull -> "()"+ joinTags ts = mconcat (zipWith (<>) ("" : repeat "|") ts)
+ src/Agentic/Scripted.hs view
@@ -0,0 +1,52 @@+-- | Providers for tests: the same flows, with no network.+module Agentic.Scripted+ ( -- * System Two+ scripted+ , replyingWith+ , respond+ , callTools+ -- * System One+ , answering+ , alwaysYes+ ) where++import Agentic.Contract (Codec (..), Contract (..))+import Agentic.Questions+import Agentic.Runtime+import Agentic.Value (Value (..))+import Data.IORef (atomicModifyIORef', newIORef)+import Data.Text (Text)++-- | Take turns from a script, in order. Running out of script is an error.+scripted :: [Action] -> IO (SystemTwo IO)+scripted actions = do+ ref <- newIORef actions+ pure $ SystemTwo $ \_ -> do+ next <- atomicModifyIORef' ref $ \case+ a : rest -> (rest, Just a)+ [] -> ([], Nothing)+ maybe (fail "Agentic.Scripted: the script ran out of turns") (pure . Turn (Raw Null)) next++-- | Answer each turn with a pure function of the conversation.+replyingWith :: Applicative m => (Conversation -> Action) -> SystemTwo m+replyingWith f = SystemTwo (pure . Turn (Raw Null) . f)++-- | A final answer, encoded with its contract.+respond :: Contract a => a -> Action+respond = Respond . encode contract++callTools :: [(Text, Value)] -> Action+callTools calls = CallTools [ToolCall ("call-" <> name) name input | (name, input) <- calls]++-- | Answer every question with a pure function of it.+answering :: Applicative m => (QuestionSpec -> Answer) -> SystemOne m+answering f = SystemOne (pure . map f . requestQuestions)++-- | Yes/no questions get probability @p@; choices and scores pick the first+-- option with certainty.+alwaysYes :: Applicative m => Probability -> SystemOne m+alwaysYes p = answering $ \case+ AskYesNo _ -> YesNoAnswer p+ AskChoice _ ((l, _) : _) -> ChoiceAnswer l [(l, 1)] 1+ AskChoice _ [] -> ChoiceAnswer "" [] 0+ AskScore _ _ -> ScoreAnswer 0 [(0, 1)] 1
+ src/Agentic/Settings.hs view
@@ -0,0 +1,49 @@+-- | Settings that several providers share, as setters that work on any+-- provider's config:+--+-- > withSystemTwo (anthropic & model "claude-sonnet-5-5" & effort Low)+-- > withSystemOne (jev & model "jev-1.13.0")+--+-- Settings only one provider has are plain functions in that provider's module.+module Agentic.Settings+ ( HasModel (..)+ , HasKey (..)+ , HasEndpoint (..)+ , HasTimeout (..)+ , HasSystem (..)+ , HasMaxTokens (..)+ , HasEffort (..)+ , Effort (..)+ , (&)+ ) where++import Data.Function ((&))+import Data.Text (Text)++class HasModel c where+ model :: Text -> c -> c++-- | The API key or token. Providers default to their environment variable.+class HasKey c where+ key :: Text -> c -> c++class HasEndpoint c where+ endpoint :: String -> c -> c++-- | How long to wait for a response, in seconds.+class HasTimeout c where+ timeout :: Int -> c -> c++-- | A system prompt for every @draft@ in the runtime.+class HasSystem c where+ system :: Text -> c -> c++class HasMaxTokens c where+ maxTokens :: Int -> c -> c++-- | How hard the model thinks. Each provider maps these to its own levels.+class HasEffort c where+ effort :: Effort -> c -> c++data Effort = Low | Medium | High | XHigh | Max+ deriving (Eq, Ord, Show, Enum, Bounded)
+ src/Agentic/Value.hs view
@@ -0,0 +1,50 @@+-- | A small JSON-shaped value. The core owns this type so that it depends only on+-- @base@ and @text@; provider packages convert to and from their wire libraries.+module Agentic.Value+ ( Value (..)+ , renderJson+ , lookupField+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Numeric (showHex)++data Value+ = Null+ | Bool Bool+ | Integer Integer+ | Number Double+ | String Text+ | Array [Value]+ | Object [(Text, Value)]+ -- ^ Fields keep their order, so rendering is stable (useful for caching).+ deriving (Eq, Ord, Show)++-- | Render as compact JSON text.+renderJson :: Value -> Text+renderJson = \case+ Null -> "null"+ Bool True -> "true"+ Bool False -> "false"+ Integer n -> T.pack (show n)+ Number d -> T.pack (show d)+ String s -> quote s+ Array vs -> "[" <> T.intercalate "," (map renderJson vs) <> "]"+ Object kvs -> "{" <> T.intercalate "," [quote k <> ":" <> renderJson v | (k, v) <- kvs] <> "}"++quote :: Text -> Text+quote s = "\"" <> T.concatMap escape s <> "\""+ where+ escape = \case+ '"' -> "\\\""+ '\\' -> "\\\\"+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ c | c < ' ' -> T.pack ("\\u" <> pad (showHex (fromEnum c) ""))+ | otherwise -> T.singleton c+ pad h = replicate (4 - length h) '0' <> h++lookupField :: Text -> [(Text, Value)] -> Maybe Value+lookupField = lookup
+ src/Agentic/ViaLLM.hs view
@@ -0,0 +1,69 @@+-- | Letting an LLM stand in as System One, when there's no Jev.+module Agentic.ViaLLM+ ( viaLLM+ ) where++import Agentic.Core (Instruction (..))+import Agentic.Questions+import Agentic.Runtime+import Agentic.Schema+import Agentic.Value (Value (..), lookupField, renderJson)+import Data.List (maximumBy)+import Data.Ord (comparing)+import Data.Text (Text)+import qualified Data.Text as T++-- | Answer judgements with one LLM turn per request. The LLM gives a+-- probability for each answer; unlike Jev's, they aren't calibrated.+viaLLM :: MonadFail m => SystemTwo m -> SystemOne m+viaLLM two = SystemOne $ \request -> do+ let qs = zip ids (requestQuestions request)+ conversation =+ Conversation+ { path = []+ , instruction = Instruction "Answer each question about the input. Give every probability as a number from 0 to 1."+ , state = requestState request+ , stateSchema = schemaOf SNull+ , tools = []+ , output = schemaOf (SObject [Field qid (questionSchema q) True | (qid, q) <- qs])+ , history = []+ }+ turn <- askSystemTwo two conversation+ case action turn of+ Respond (Object kvs) -> either (fail . T.unpack) pure (traverse (\(qid, q) -> answer q =<< field' qid kvs) qs)+ Respond other -> fail ("viaLLM: expected an object of answers, got " <> T.unpack (renderJson other))+ CallTools _ -> fail "viaLLM: the model called a tool while answering questions"+ where+ ids = ["q" <> T.pack (show n) | n <- [0 :: Int ..]]+ field' k kvs = maybe (Left ("missing " <> k)) Right (lookupField k kvs)++questionSchema :: QuestionSpec -> Schema+questionSchema = \case+ AskYesNo q ->+ documentSchema q (schemaOf (SObject [Field "probabilityYes" (documentSchema "The probability that the answer is yes" (schemaOf SNumber)) True]))+ AskChoice q opts -> distribution (q <> " Give each option's probability; they should sum to 1.") opts+ AskScore q levels -> distribution (q <> " The options are ordered levels, lowest first. Give each level's probability; they should sum to 1.") levels+ where+ distribution q opts =+ documentSchema q (schemaOf (SObject [Field l (documentSchema (maybe l id d) (schemaOf SNumber)) True | (l, d) <- opts]))++answer :: QuestionSpec -> Value -> Either Text Answer+answer spec v = case (spec, v) of+ (AskYesNo _, Object kvs) -> YesNoAnswer <$> (number =<< get "probabilityYes" kvs)+ (AskChoice _ opts, Object kvs) -> do+ ps <- traverse (\(l, _) -> (l,) <$> (number =<< get l kvs)) opts+ let (best, p) = maximumBy (comparing snd) ps+ pure (ChoiceAnswer best ps p)+ (AskScore _ levels, Object kvs) -> do+ ps <- traverse (\(l, _) -> number =<< get l kvs) levels+ let weights = map probability ps+ total = sum weights+ pos = if total > 0 then sum (zipWith (*) [0 ..] weights) / total else 0+ pure (ScoreAnswer pos (zip [0 ..] ps) (maximum ps))+ (_, other) -> Left ("expected an object, got " <> renderJson other)+ where+ get k kvs = maybe (Left ("missing " <> k)) Right (lookupField k kvs)+ number = \case+ Number d -> Right (fromBasisPoints d)+ Integer n -> Right (fromBasisPoints (fromInteger n))+ other -> Left ("expected a probability, got " <> renderJson other)
+ test/Spec.hs view
@@ -0,0 +1,257 @@+module Main (main) where++import Agentic+import Agentic.Scripted+import Agentic.Schema (Field (..), Schema (..))+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Test.Hspec hiding (describe)+import qualified Test.Hspec++-- ---------------------------------------------------------------------------+-- README types++data Joke = Joke {genre :: Text, setup :: Text, punchline :: Text}+ deriving (Generic, Show, Eq, Contract)++data BetterJoke+ = DadJoke {setup' :: Text, punchline' :: Text}+ | OneLiner {line :: Text}+ | KnockKnock {whosThere :: Text, punchline' :: Text}+ deriving (Generic, Show, Eq, Contract)++data Groan = Mild | Solid | Unbearable+ deriving (Generic, Show, Eq)++instance Options Groan where+ options =+ described+ "How much the audience groans"+ [ option Mild "A polite smile"+ , option Solid "An audible groan"+ , option Unbearable "People get up and leave"+ ]++deriving via Enumeration Groan instance Contract Groan++newtype Rating = Rating Int+ deriving (Show, Eq)++instance Contract Rating where+ contract = mapCodec Rating (\(Rating n) -> n) (between 1 10 contract)++data Review = Review {funnyAnswer :: YesNo, groanAnswer :: Score Groan}+ deriving (Show, Eq)++described' :: Codec Joke+described' =+ record "A joke, split into its parts" $+ Joke+ <$> required "genre" "The style of joke" genre+ <*> required "setup" "The setup line" setup+ <*> required "punchline" "The line that lands it" punchline++funny :: Questions YesNo+funny = yesNo "Would a 10-year-old laugh at this joke?"++groan :: Questions (Score Groan)+groan = score "How much will the audience groan?"++joke :: Joke+joke = Joke "pun" "Why was the scarecrow promoted?" "He was outstanding in his field."++-- ---------------------------------------------------------------------------+-- Helpers++-- | A runtime with a script for System Two and fixed answers for System One.+testRuntime :: [Action] -> Probability -> IO (Runtime IO)+testRuntime turns p = do+ two <- scripted turns+ pure runtime {systemOne = alwaysYes p, systemTwo = two}++roundTrips :: (Eq a, Show a) => Codec a -> a -> Expectation+roundTrips c a = decode c (encode c a) `shouldBe` Right a++main :: IO ()+main = hspec $ do+ describe' "Contracts" $ do+ it "round-trips a derived record" $+ roundTrips contract joke++ it "round-trips a derived sum as tagged objects" $ do+ roundTrips contract (OneLiner "I'm on a seafood diet.")+ encode contract (OneLiner "x")+ `shouldBe` Object [("tag", String "OneLiner"), ("line", String "x")]++ it "encodes an Options type as its labels" $ do+ encode contract Solid `shouldBe` String "Solid"+ decode contract (String "Unbearable") `shouldBe` Right Unbearable++ it "names derived schemas after their type" $+ title (codecSchema (contract @Joke)) `shouldBe` Just "Joke"++ it "keeps descriptions written in the codec" $+ case shape (codecSchema described') of+ SObject fs -> map (doc . fieldSchema) 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 shape (codecSchema (field "punchline" "No explanation" (contract @Joke))) of+ SObject fs -> map (doc . fieldSchema) fs `shouldBe` [Nothing, Nothing, Just "No explanation"]+ other -> expectationFailure (show other)++ it "checks constraints the schema can't express" $ do+ decode (contract @Rating) (Integer 7) `shouldBe` Right (Rating 7)+ decode (contract @Rating) (Integer 11) `shouldBe` Left "must be between 1 and 10"++ describe' "Questions" $ do+ it "batches combined questions into one request" $+ map (\case AskYesNo _ -> "yesNo"; AskScore _ ls -> "score " <> T.pack (show (length ls)); AskChoice _ _ -> "choice" :: Text) (specs (Review <$> funny <*> groan))+ `shouldBe` ["yesNo", "score 3"]++ it "decodes answers back to typed values" $+ decodeAnswers (Review <$> funny <*> groan) [YesNoAnswer 0.8, ScoreAnswer 1.2 [(1, 0.7), (2, 0.3)] 0.6]+ `shouldBe` Right (Review (YesNo 0.8) (Score 1.2 [(Solid, 0.7), (Unbearable, 0.3)] 0.6))++ describe' "interpret" $ do+ it "drafts a typed value" $ do+ rt <- testRuntime [respond joke] 1+ interpret rt (draft @Joke "a joke please") () `shouldReturn` joke++ it "sends a failed check back to the model and tries again" $ do+ rt <- testRuntime [Respond (Integer 42), Respond (Integer 7)] 1+ interpret rt (draft @Rating "rate this joke") joke `shouldReturn` Rating 7++ it "runs a tool loop until the model responds" $ do+ calls <- newIORef (0 :: Int)+ let lookupGenre = tool @Text @Text "genre_of" "Look up a joke's genre" (act (\t -> modifyIORef calls (+ 1) >> pure ("pun about " <> t)))+ rt <- testRuntime [callTools [("genre_of", String "scarecrows")], respond joke] 1+ interpret rt (draftWith @Joke [lookupGenre] "a joke please") () `shouldReturn` joke+ readIORef calls `shouldReturn` 1++ it "tells the model about unknown tools instead of failing" $ do+ events <- newIORef []+ rt <- testRuntime [callTools [("nope", Null)], respond joke] 1+ let rt' = observing (\e -> modifyIORef events (happened e :)) rt+ _ <- interpret rt' (draft @Joke "a joke please") ()+ results <- readIORef events+ [r | ToolReturned _ r <- results] `shouldBe` [ToolFailed "there is no tool named nope"]++ it "judges with System One" $ do+ rt <- testRuntime [] 0.8+ interpret rt (judge funny) joke `shouldReturn` YesNo 0.8++ it "keeps items that pass" $ do+ rt <- testRuntime [] 0.8+ interpret rt (keep 0.7 funny) [joke, joke] `shouldReturn` [joke, joke]+ interpret rt (keep 0.9 funny) [joke, joke] `shouldReturn` []++ it "gates into branches" $ do+ 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"}++ it "runs structure: fanout and each" $ do+ rt <- testRuntime [respond joke, respond (Rating 3)] 1+ interpret rt (draft @Joke "a joke" >>> (returnA &&& draft @Rating "rate it")) () `shouldReturn` (joke, Rating 3)+ interpret rt (each (arr (* 2))) [1, 2, 3 :: Int] `shouldReturn` [2, 4, 6]+ interpret rt (arr (+ 1) *** arr (* 2)) (1, 5 :: Int) `shouldReturn` (2 :: Int, 10)+ interpret rt (repeatUntil (>= 10) (arr (* 2))) (3 :: Int) `shouldReturn` 12+ interpret rt (repeatUntil (>= 10) (arr (* 2))) (50 :: Int) `shouldReturn` 50+ interpret rt (second (arr show)) ('a', 7 :: Int) `shouldReturn` ('a', "7")+ interpret rt (left (arr (+ 1))) (Left 1 :: Either Int Char) `shouldReturn` Left (2 :: Int)+ interpret rt (left (arr (+ 1))) (Right 'x' :: Either Int Char) `shouldReturn` (Right 'x' :: Either Int Char)++ it "fails clearly without a System One" $ do+ interpret runtime (judge funny) joke `shouldThrow` (== NoSystemOne)++ describe' "describe" $ do+ it "draws the tree without running anything" $ do+ let flow :: Agentic IO () [Joke]+ flow =+ draft @[Joke] "ten jokes please"+ >>> keep 0.7 funny+ >>> each (draftWith @Joke [tool @Text @Text "search" "Search" (act pure)] "polish this joke")+ T.lines (renderTree (Agentic.describe flow))+ `shouldBe` [ "draft @[Joke] \"ten jokes please\""+ , "keep 0.7 each"+ , "└─ judge yes/no \"Would a 10-year-old laugh at this joke?\" (keeping its input)"+ , "each"+ , "└─ draft @Joke \"polish this joke\""+ , " └─ tool search act"+ ]++ it "never hides a branch, even when it's only glue" $ do+ let flow :: Agentic IO (Joke, Joke) (Rating, Text)+ flow = draft @Rating "rate it" *** arr genre+ T.lines (renderTree (Agentic.describe flow))+ `shouldBe` ["both halves", "├─ first → draft @Rating \"rate it\"", "└─ second → arr"]++ it "draws first and second alike, and left and right alike" $ do+ let d = draft @Rating "rate it"+ tree :: Agentic IO i o -> [Text]+ tree = T.lines . renderTree . Agentic.describe+ tree (first d :: Agentic IO (Joke, Int) (Rating, Int)) `shouldBe` ["both halves", "├─ first → draft @Rating \"rate it\"", "└─ second → pass"]+ tree (second d :: Agentic IO (Int, Joke) (Int, Rating)) `shouldBe` ["both halves", "├─ first → pass", "└─ second → draft @Rating \"rate it\""]+ tree (left d :: Agentic IO (Either Joke Int) (Either Rating Int)) `shouldBe` ["branch", "├─ left → draft @Rating \"rate it\"", "└─ right → pass"]++ it "puts a description under the name in diagrams, not in the tree" $ do+ let flow :: Agentic IO Joke Joke+ flow = note "polish" "Tidy the wording" (draft @Joke "polish it" >>> note "check" "Make sure it's still a joke" (arr id))+ d = Agentic.describe flow+ any (T.isInfixOf "Tidy the wording") (T.lines (mermaid d)) `shouldBe` True+ any (T.isInfixOf "act\\ncheck\\nMake sure") (T.lines (dot d)) `shouldBe` False+ any (T.isInfixOf "arr\\ncheck\\nMake sure it's still a joke") (T.lines (dot d)) `shouldBe` True+ any (T.isInfixOf "Tidy the wording") (T.lines (renderTree d)) `shouldBe` False++ it "groups a parallel branch that's several steps in a row" $ do+ let flow :: Agentic IO Joke (Joke, Rating)+ flow = (draft @Joke "rewrite it" >>> draft @Joke "shorten it") &&& draft @Rating "rate it"+ T.lines (renderTree (Agentic.describe flow))+ `shouldBe` [ "together"+ , "├─ in order"+ , "│ ├─ draft @Joke \"rewrite it\""+ , "│ └─ draft @Joke \"shorten it\""+ , "└─ draft @Rating \"rate it\""+ ]++ it "shows a loop and what it runs" $ do+ let flow :: Agentic IO Joke Joke+ flow = repeatUntil ((== "kids") . genre) (draft @Joke "make it more kid-friendly") `named` "polish until it's for kids"+ T.lines (renderTree (Agentic.describe flow))+ `shouldBe` ["polish until it's for kids repeatUntil", "└─ draft @Joke \"make it more kid-friendly\""]++ it "draws a fork that joins again in mermaid" $ do+ let flow :: Agentic IO Joke (Joke, Rating)+ flow = returnA &&& draft @Rating "rate it"+ edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow)))+ edges `shouldBe` [" input --> n0", " input --> output", " n0 --> output"]++ it "draws the same graph as DOT, with boxes as clusters" $ do+ let flow :: Agentic IO [Joke] [Joke]+ flow = each (draft @Joke "polish it") `named` "polish"+ out = mermaid (Agentic.describe flow)+ dotOut = T.lines (dot (Agentic.describe flow))+ filter (T.isInfixOf "->") dotOut `shouldBe` [" input -> n2;", " n2 -> output;"]+ length (filter (T.isInfixOf "subgraph cluster_") dotOut) `shouldBe` 2+ length (filter (T.isInfixOf "subgraph ") (T.lines out)) `shouldBe` 2++ it "sends a loop's again edge back to the body's first step, in both formats" $ do+ let flow :: Agentic IO Joke Joke+ flow = repeatUntil ((== "kids") . genre) (draft @Joke "make it kid-friendly" >>> act pure `named` "show it")+ d = Agentic.describe flow+ filter (T.isInfixOf "again") (T.lines (mermaid d)) `shouldBe` [" n2 -.->|again| n1"]+ filter (T.isInfixOf "again") (T.lines (dot d)) `shouldBe` [" n2 -> n1 [label=\"again\", style=dashed];"]++ it "expands a tool that calls itself only once" $ do+ let researcher :: Agentic IO Text Text+ researcher = draftWith @Text [tool "research" "Research deeper" researcher] "research this"+ T.lines (renderTree (Agentic.describe researcher))+ `shouldBe` [ "draft @Text \"research this\""+ , "└─ tool research draft @Text \"research this\""+ , " └─ tool research (see above)"+ ]+ where+ describe' = Test.Hspec.describe