diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,22 @@ # Changelog for agentic +## 0.2.0.5 - 2026-10-06 + +* `takeFirst` and `takeSecond` do what `arr fst` and `arr snd` do, but a + diagram can follow them. `StepInfo` has `FirstHalf` and `SecondHalf` for + them. +* `:/\` is a pair, as a type and a pattern, so the nested pairs `&&&` builds + read flat: `\(creature :/\ picture :/\ card) -> ...`. +* `mermaid` and `dot` follow each half of a pair from `&&&` or `***`, so a + later `first`, `second` or `***` is wired only to the half it gets. + Previously every step before the pair was wired into both halves. +* A step reached by the same node along several routes, such as both sides of + a `|||`, gets one edge instead of one per route. +* A `repeatUntil`'s input is drawn going straight out as well as through the + body, since the condition is checked before the first run. +* `(a &&& b) &&& c` is described as a pair inside a pair, not flattened like + `a &&& b &&& c`. + ## 0.2.0.4 - 2026-10-06 * Record fields are no longer functions: the packages are written with diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -260,7 +260,7 @@ draft @[Creature] "Name 10 prehistoric creatures a grade 5 class might have heard of. Include a mix of kinds, not only dinosaurs." >>> each classify >>> arr (partition (clearly Dinosaur 0.8)) `named` "split off the clear dinosaurs (≥ 0.8)" - >>> (each (arr fst >>> exhibit) *** arr (map notADinosaur) `named` "note what the others were") + >>> (each (takeFirst >>> exhibit) *** arr (map notADinosaur) `named` "note what the others were") >>> arr (uncurry Exhibit) >>> draft @Poster "Create a poster of these dinosaurs for a grade 5 class. Add a corner about the creatures that weren't dinosaurs, and what they were." @@ -273,9 +273,12 @@ (returnA &&& draft @DinoPic "Draw an ascii picture of this dinosaur, 10 lines high" &&& draft @TrumpCard "Make a trump card for this dinosaur") `named` "exhibit" - >>> arr (\(c, (p, t)) -> Entry c p t) + >>> arr (\(dinosaur :/\ picture :/\ card) -> Entry dinosaur picture card) ``` +`a &&& b &&& c` builds the nested pair `(a, (b, c))`, and `:/\` matches it +without the brackets: `dinosaur :/\ picture :/\ card`. It works as a type too. + The trump card's stats use a `Stat` contract that checks 1 to 10, so every card uses the same scale. And the poster is drafted from a named `Exhibit` record rather than a tuple, so Claude sees `dinosaurs` and `notDinosaurs` instead of @@ -352,7 +355,7 @@ n3 -->|first| n6 n3 -->|first| n7 n3 -->|second| n8 - n3 -->|first| n9 + n3 --> n9 n6 --> n9 n7 --> n9 n8 --> n9 @@ -362,6 +365,11 @@ `describe` returns a plain `Description` you can walk yourself, and `descriptionValue` turns it into JSON for UIs and other agents. The tree hides unnamed glue between steps, but never a branch. + +The diagram follows each half of a pair from `&&&` or `***` to wherever it +goes next, but it can't see inside an `arr`, so `arr fst` loses track of which +step the half came from. `takeFirst` and `takeSecond` do the same job and keep +it. ### Naming things diff --git a/agentic.cabal b/agentic.cabal --- a/agentic.cabal +++ b/agentic.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: agentic -version: 0.2.0.4 +version: 0.2.0.5 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. diff --git a/src/Agentic/Core.hs b/src/Agentic/Core.hs --- a/src/Agentic/Core.hs +++ b/src/Agentic/Core.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} -- | Flows: typed, inspectable descriptions of agentic work. module Agentic.Core @@ -22,6 +23,11 @@ , repeatUntil , note , named + -- * Plumbing + , takeFirst + , takeSecond + , (:/\) + , pattern (:/\) -- * Judgement helpers , keep , gate @@ -63,6 +69,10 @@ -- ^ 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 + TakeFirst :: Step m (a, b) a + -- ^ 'takeFirst': unlike @arr fst@, 'Agentic.Describe.describe' can see + -- which half it keeps. + TakeSecond :: Step m (a, b) b Act :: (i -> m o) -> Step m i o Draft :: Codec i -> Codec o -> Instruction -> [Tool m] -> Step m i o Judge :: Codec i -> Questions o -> Step m i o @@ -110,6 +120,29 @@ 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 + +-- | The first half of a pair. It does what @arr fst@ does, but a diagram can +-- follow it: after @&&&@ or @***@, it knows which step the half came from. +takeFirst :: Agentic m (a, b) a +takeFirst = Step TakeFirst + +-- | The second half of a pair, like 'takeFirst'. +takeSecond :: Agentic m (a, b) b +takeSecond = Step TakeSecond + +infixr 6 :/\ + +-- | A pair, written so that the nested pairs @&&&@ and @***@ build read flat: +-- @a &&& b &&& c@ gives an @A :\/\\ B :\/\\ C@, which is @(A, (B, C))@. +type a :/\ b = (a, b) + +-- | Build or match a pair the same way: +-- +-- > arr (\(creature :/\ picture :/\ card) -> Entry creature picture card) +pattern (:/\) :: a -> b -> (a, b) +pattern a :/\ b = (a, b) + +{-# COMPLETE (:/\) #-} -- | An LLM writes an @o@ from the step's input. -- diff --git a/src/Agentic/Describe.hs b/src/Agentic/Describe.hs --- a/src/Agentic/Describe.hs +++ b/src/Agentic/Describe.hs @@ -44,6 +44,10 @@ -- ^ The input, unchanged ('returnA'). | Glue -- ^ @arr@: a pure function. + | FirstHalf + -- ^ 'takeFirst'. + | SecondHalf + -- ^ 'takeSecond'. | Effect -- ^ @act@: plain code with an effect. | DraftInfo @@ -70,7 +74,9 @@ 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)) + -- Only the right is flattened: @(a &&& b) &&& c@ is a different shape of + -- pair from @a &&& b &&& c@, and the graph routes by that shape. + Fanout f g -> 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) @@ -90,6 +96,8 @@ Pass -> Identity Wrap _ -> Identity Arr _ -> Glue + TakeFirst -> FirstHalf + TakeSecond -> SecondHalf Act _ -> Effect Draft input out instruction tools -> DraftInfo instruction input.schema out.schema (map toolInfo tools) @@ -119,6 +127,8 @@ trees seen = \case Leaf Identity -> (seen, []) Leaf Glue -> (seen, []) + Leaf FirstHalf -> (seen, []) + Leaf SecondHalf -> (seen, []) Leaf info -> leaf Nothing info Sequence ds -> onSnd concat (mapAccumL trees seen ds) Together ds -> @@ -159,7 +169,7 @@ 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") []]) + (s', []) -> (s', [Node (plumbing d) []]) r -> r toolTree s t | t.name `elem` s = (s, Node ("tool " <> t.name <> " (see above)") []) @@ -171,6 +181,15 @@ [] -> Node (l <> " → pass") [] ts -> Node l ts +-- | How a branch that's only plumbing shows in the tree view. +plumbing :: Description -> Text +plumbing = \case + d | passes d -> "pass" + Leaf FirstHalf -> "takeFirst" + Leaf SecondHalf -> "takeSecond" + Annotated _ d -> plumbing d + _ -> "arr" + -- | Does this part of a flow only pass its input through? passes :: Description -> Bool passes = \case @@ -235,7 +254,7 @@ where flow = do item (ItemNode "input" Terminal ["input"]) - exits <- build InSequence [("input", Nothing)] d + exits <- build InSequence (Sources [("input", Nothing)]) d item (ItemNode "output" Terminal ["output"]) connect exits "output" @@ -243,9 +262,31 @@ -- 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)] +-- | Where the next step's input comes from: nodes, each with an optional edge +-- label, or a pair (after @&&&@ or @***@) whose halves are known separately, so +-- a later @first@, @second@ or @***@ wires each half to its own flow. +data From = Sources [(Text, Maybe Text)] | Pair From From +-- | Every node a 'From' draws on, once each. A node reached by routes with +-- different labels (both sides of a @|||@) keeps one unlabelled edge. +sources :: From -> [(Text, Maybe Text)] +sources = dedupe . go + where + go = \case + Sources s -> s + Pair a b -> go a <> go b + dedupe = \case + [] -> [] + (n, l) : rest -> + let others = [l' | (n', l') <- rest, n' == n] + in (n, if all (== l) others then l else Nothing) : dedupe [x | x@(n', _) <- rest, n' /= n] + +-- | The two sides of a @|||@ joining again: where both made a pair, so does +-- the join. +merge :: From -> From -> From +merge (Pair a b) (Pair c d) = Pair (merge a c) (merge b d) +merge x y = Sources (sources (Pair x y)) + -- | A counter for ids, the items of each open box (innermost first), and edges. data BuildState = BuildState Int [[Item]] [Edge] @@ -284,14 +325,14 @@ 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 +connect from to = mapM_ (\(f, l) -> edge (Edge f to l Flow)) (sources from) node :: From -> [Text] -> Build From node from label = do n <- fresh item (ItemNode n StepNode label) connect from n - pure [(n, Nothing)] + pure (Sources [(n, Nothing)]) box :: [Text] -> Build a -> Build (Text, a) box label inside = do @@ -306,28 +347,51 @@ build :: Context -> From -> Description -> Build From build context from = \case Leaf Identity -> pure from + -- A known pair's half goes on exactly; otherwise it's like any @arr@. + Leaf FirstHalf | Pair a _ <- from -> pure a + Leaf SecondHalf | Pair _ b <- from -> pure b + Leaf FirstHalf -> half "takeFirst" + Leaf SecondHalf -> half "takeSecond" Leaf Glue -> case context of - InSequence -> pure from + -- An @arr@ can take a pair apart any way it likes, so its halves are lost, + -- and so is what the edge labels inside it said. + InSequence -> pure $ case from of + Pair _ _ -> Sources [(n, Nothing) | (n, _) <- sources from] + Sources _ -> 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) + Together ds -> pairUp <$> mapM (build InBranch from) ds + -- A pair whose halves are known sends each to its flow. Otherwise every + -- source might hold either half, so the edges say which half they carry. + Halves l r -> case from of + Pair a b -> Pair <$> build InBranch a l <*> build InBranch b r + _ -> Pair <$> build InBranch (labelled "first") l <*> build InBranch (labelled "second") r + Branch l r -> merge <$> build InBranch (labelled "left") l <*> build InBranch (labelled "right") r + ForEach f -> Sources . sources . snd <$> box ["each"] (build InSequence (Sources (sources 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) + entries <- entriesSince before (map fst (sources 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 + mapM_ (\(e, _) -> mapM_ (\t -> edge (Edge e t (Just "again") Again)) targets) (sources exits) + -- The condition is checked before the first run, so the input can leave + -- without going through the body. + pure (merge from exits) Annotated n (Leaf info) | not (passes (Leaf info)) -> step (Just n) info Annotated n f -> snd <$> box (n.name : maybe [] pure n.description) (build InSequence from f) where - labelled l = [(f, Just l) | (f, _) <- from] + labelled l = Sources [(f, Just l) | (f, _) <- sources from] + -- A half of a pair the graph can't follow: plumbing, like @arr@. + half name = case context of + InSequence -> pure from + InBranch -> node from [name] + pairUp = \case + [] -> from + [x] -> x + x : xs -> Pair x (pairUp xs) chain acc = \case [] -> pure acc x : xs -> build InSequence acc x >>= (`chain` xs) @@ -344,7 +408,7 @@ ( \t -> do n <- fresh item (ItemNode n ToolNode ["tool " <> t.name]) - mapM_ (\(e, _) -> edge (Edge e n Nothing Uses)) exits + mapM_ (\(e, _) -> edge (Edge e n Nothing Uses)) (sources exits) ) tools _ -> pure () @@ -358,6 +422,8 @@ (kind, details) = case info of Identity -> ("pass", []) Glue -> ("arr", []) + FirstHalf -> ("takeFirst", []) + SecondHalf -> ("takeSecond", []) Effect -> ("act", []) DraftInfo instruction _ out _ -> ("draft @" <> typeLabel out, [quoted instruction.text]) JudgeInfo _ [q] -> ("judge", [questionText q]) @@ -469,6 +535,8 @@ leaf = \case Identity -> node "pass" [] Glue -> node "arr" [] + FirstHalf -> node "takeFirst" [] + SecondHalf -> node "takeSecond" [] Effect -> node "act" [] DraftInfo instruction input out tools -> node diff --git a/src/Agentic/Interpret.hs b/src/Agentic/Interpret.hs --- a/src/Agentic/Interpret.hs +++ b/src/Agentic/Interpret.hs @@ -43,6 +43,8 @@ step path s x = case s of Pass -> pure x Wrap f -> pure (f x) + TakeFirst -> pure (fst x) + TakeSecond -> pure (snd x) Arr f -> pure (f x) Act f -> emit path Acted >> f x Judge input qs diff --git a/test/Portable.hs b/test/Portable.hs --- a/test/Portable.hs +++ b/test/Portable.hs @@ -19,15 +19,15 @@ -- --------------------------------------------------------------------------- -- Explicit codecs: a record, and a sum with payloads -data Joke = Joke Text Text +data Joke = Joke {setup :: Text, punchline :: 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) + <$> required "setup" "The setup line" (.setup) + <*> required "punchline" "The line that lands it" (.punchline) data Figure = Circle Double | Rect Double Double deriving (Show, Eq) @@ -157,6 +157,13 @@ 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. + -- 7. Plumbing a diagram can follow runs like arr fst and arr snd. + let halves = (,) <$> interpret handlers (arr (\x -> (x, x + 1)) >>> takeFirst) (1 :: Int) <*> interpret handlers (arr (\x -> (x, x + 1)) >>> takeSecond) (1 :: Int) + check "takeFirst and takeSecond keep their halves" (fst (halves.runPure world0) == (1, 2)) + let flat :: Int :/\ Text :/\ Bool + flat = 1 :/\ "two" :/\ True + check "a :/\\ pair builds and matches nested pairs" (flat == (1, ("two", True)) && (case flat of _ :/\ t :/\ _ -> t == "two")) + + -- 8. 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -229,6 +229,30 @@ edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow))) edges `shouldBe` [" input --> n0", " input --> output", " n0 --> output"] + it "wires second to the second half of a known pair" $ do + let flow :: Agentic IO Joke (Joke, Rating) + flow = (draft @Joke "retell it" &&& draft @Rating "rate it") >>> second (draft @Rating "rate it again") + edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow))) + edges `shouldBe` [" input --> n0", " input --> n1", " n1 --> n2", " n0 --> output", " n2 --> output"] + + it "joins a pass-through from both sides of a choice with one edge" $ do + let flow :: Agentic IO (Either Joke Joke) (Joke, Rating) + flow = (returnA &&& draft @Rating "rate it") ||| (returnA &&& draft @Rating "rate it harshly") + edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow))) + edges `shouldBe` [" input -->|left| n0", " input -->|right| n1", " input --> output", " n0 --> output", " n1 --> output"] + + it "follows takeSecond to the half it keeps" $ do + let flow :: Agentic IO Joke Rating + flow = (draft @Joke "retell it" &&& draft @Rating "rate it") >>> takeSecond >>> draft @Rating "rate it again" + edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow))) + edges `shouldBe` [" input --> n0", " input --> n1", " n1 --> n2", " n2 --> output"] + + it "lets a loop's input leave without going through the body" $ do + let flow :: Agentic IO Joke Joke + flow = repeatUntil ((== "kids") . (.genre)) (draft @Joke "make it kid-friendly") >>> act pure `named` "show it" + edges = filter (T.isInfixOf "-->") (T.lines (mermaid (Agentic.describe flow))) + edges `shouldBe` [" input --> n1", " input --> n2", " n1 --> n2", " n2 --> 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"