packages feed

agentic-io (empty) → 0.2.0.0

raw patch · 8 files changed

+470/−0 lines, 8 filesdep +aesondep +agenticdep +agentic-aeson

Dependencies added: aeson, agentic, agentic-aeson, agentic-io, async, base, bytestring, containers, directory, filepath, hspec, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for agentic-io++## 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-io.cabal view
@@ -0,0 +1,59 @@+cabal-version:      3.0+name:               agentic-io+version:            0.2.0.0+synopsis:           IO helpers for agentic runtimes: concurrency, recording and replay+description:+  Runs a flow's independent work concurrently, records model calls to a file and replays them, and loads provider keys from a .env file.+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-io++library+  default-language: GHC2021+  default-extensions: LambdaCase OverloadedStrings+  ghc-options:      -Wall+  hs-source-dirs:   src+  exposed-modules:+    Agentic.IO+    Agentic.IO.Concurrent+    Agentic.IO.DotEnv+    Agentic.IO.Store+  build-depends:+    , agentic          ==0.2.*+    , agentic-aeson    ==0.2.*+    , aeson            >=2.1 && <2.3+    , async      >=2.2 && <2.3+    , bytestring       >=0.11 && <0.13+    , containers       >=0.6 && <0.9+    , text             >=2.0 && <2.2+    , base       >=4.18 && <5+    , directory        >=1.3 && <1.4+    , filepath         >=1.4 && <1.6+test-suite agentic-io-test+  default-language: GHC2021+  default-extensions: DeriveAnyClass LambdaCase OverloadedStrings+  ghc-options:      -Wall+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs+  build-depends:+    , agentic          ==0.2.*+    , agentic-io       ==0.2.*+    , base             >=4.18 && <5+    , directory        >=1.3 && <1.4+    , filepath         >=1.4 && <1.6+    , hspec            >=2.10 && <3+    , text             >=2.0 && <2.2
+ src/Agentic/IO.hs view
@@ -0,0 +1,10 @@+-- | IO helpers for runtimes.+module Agentic.IO+  ( module Agentic.IO.Concurrent+  , module Agentic.IO.DotEnv+  , module Agentic.IO.Store+  ) where++import Agentic.IO.Concurrent+import Agentic.IO.DotEnv+import Agentic.IO.Store
+ src/Agentic/IO/Concurrent.hs view
@@ -0,0 +1,12 @@+-- | Running a flow's independent work at the same time.+module Agentic.IO.Concurrent+  ( concurrently+  ) where++import Agentic.Runtime (Runtime (..))+import Control.Concurrent.Async (mapConcurrently)++-- | Run 'Agentic.Core.each', 'Control.Arrow.&&&' and parallel tool calls concurrently. If one+-- branch fails, the others are cancelled and the error is raised in the caller.+concurrently :: Runtime IO -> Runtime IO+concurrently rt = rt {parallel = mapConcurrently id}
+ src/Agentic/IO/DotEnv.hs view
@@ -0,0 +1,44 @@+-- | Loading provider keys from a @.env@ file.+module Agentic.IO.DotEnv+  ( loadDotEnv+  , parseDotEnv+  ) where++import Control.Monad (filterM, forM_, when)+import Data.Char (isSpace)+import Data.List (dropWhileEnd, isPrefixOf)+import Data.Maybe (isNothing, listToMaybe)+import System.Directory (doesFileExist, getCurrentDirectory)+import System.Environment (lookupEnv, setEnv)+import System.FilePath (takeDirectory, (</>))++-- | Find the nearest @.env@, from the current directory upwards, and set each+-- variable it defines that isn't already set. Returns the file it loaded.+loadDotEnv :: IO (Maybe FilePath)+loadDotEnv = do+  here <- getCurrentDirectory+  found <- listToMaybe <$> filterM doesFileExist (map (</> ".env") (upwards here))+  forM_ found $ \file -> do+    vars <- parseDotEnv <$> readFile file+    forM_ vars $ \(key, value) -> do+      existing <- lookupEnv key+      when (isNothing existing && not (null value)) (setEnv key value)+  pure found+  where+    upwards dir+      | takeDirectory dir == dir = [dir]+      | otherwise = dir : upwards (takeDirectory dir)++-- | @KEY=value@ lines. Blank lines and @#@ comments are skipped, an @export@+-- prefix is allowed, and matching quotes around a value are removed.+parseDotEnv :: String -> [(String, String)]+parseDotEnv = concatMap entry . lines+  where+    entry raw = case break (== '=') (strip (dropExport (strip raw))) of+      (key, '=' : value) | not (null key), not ("#" `isPrefixOf` key) -> [(strip key, unquote (strip value))]+      _ -> []+    dropExport l = if "export " `isPrefixOf` l then drop 7 l else l+    strip = dropWhileEnd isSpace . dropWhile isSpace+    unquote v = case v of+      q : rest | q `elem` ("\"'" :: String), not (null rest), last rest == q -> init rest+      _ -> v
+ src/Agentic/IO/Store.hs view
@@ -0,0 +1,224 @@+-- | Recording model calls to a file, and replaying them.+--+-- > rt <- pure runtime >>= withSystemOne jev >>= withSystemTwo anthropic >>= withStore ReplayOrRecord "dino.jsonl"+--+-- Every System One and System Two call is a request: a t'Conversation' or a+-- t'JudgeRequest'. The store keys each answer by its whole request, so an answer+-- is replayed exactly when the model would be asked exactly the same thing.+-- Change an instruction or a threshold upstream and only the calls it affects+-- go to the model again.+--+-- Only model calls are stored. @act@ steps and tool bodies run for real, even+-- when replaying.+module Agentic.IO.Store+  ( Mode (..)+  , withStore+  , StoreMiss (..)+  ) where++import Agentic.Aeson (fromAeson)+import Agentic.Core (Instruction (..), Note (..))+import Agentic.JsonSchema (jsonSchema)+import Agentic.Questions+import Agentic.Runtime+import Agentic.Value (Value (..), lookupField, renderJson)+import Control.Concurrent.MVar+import Control.Exception (Exception (..), throwIO)+import Control.Monad (when)+import qualified Data.Aeson as J+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IORef+import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory (doesFileExist)+import System.IO (IOMode (..), hFlush, withFile)++data Mode+  = Record+    -- ^ Call the models and record every answer, starting the file afresh.+  | Replay+    -- ^ Answer only from the file. A request that isn't there is a t'StoreMiss'.+  | ReplayOrRecord+    -- ^ Answer from the file when it can, and call the models (and record the+    -- answer) when it can't.+  deriving (Eq, Show)++-- | A replayed run asked something the recording doesn't have.+data StoreMiss = StoreMiss FilePath Text+  deriving (Show)++instance Exception StoreMiss where+  displayException (StoreMiss file what) =+    "The recording " <> file <> " has no answer for " <> T.unpack what+      <> ". Something upstream changed; record again, or use ReplayOrRecord."++-- | Wrap a runtime's System One and System Two with a store in @file@.+withStore :: Mode -> FilePath -> Runtime IO -> IO (Runtime IO)+withStore mode file rt = do+  existing <- if mode == Record then pure [] else load file+  when (mode == Record) (writeFile file "")+  answers <- newIORef (Map.fromList [(canonical k, a) | (k, a) <- existing])+  lock <- newMVar ()+  let lookupOr key what live = do+        known <- Map.lookup (canonical key) <$> readIORef answers+        case (known, mode) of+          (Just answer, _) | mode /= Record -> pure answer+          (_, Replay) -> throwIO (StoreMiss file what)+          _ -> do+            answer <- live+            atomicModifyIORef' answers (\m -> (Map.insert (canonical key) answer m, ()))+            withMVar lock $ \_ -> append file key answer+            pure answer+      one request =+        lookupOr (judgeKey request) ("a judgement: " <> questionsText request) (encodeAnswers <$> askSystemOne (systemOne rt) request)+          >>= decodedAs (MalformedAnswers ("unreadable stored answers in " <> T.pack file)) decodeAnswers'+      two conversation =+        lookupOr (turnKey conversation) ("a turn of: " <> instructionText (instruction conversation)) (encodeTurn <$> askSystemTwo (systemTwo rt) conversation)+          >>= decodedAs (MalformedAnswers ("an unreadable stored turn in " <> T.pack file)) decodeTurn+  pure rt {systemOne = SystemOne one, systemTwo = SystemTwo two}+  where+    decodedAs :: FlowError -> (Value -> Maybe a) -> Value -> IO a+    decodedAs err decode' = maybe (throwIO err) pure . decode'+    questionsText r = T.intercalate "; " (map question (requestQuestions r))+    question = \case+      AskYesNo q -> q+      AskChoice q _ -> q+      AskScore q _ -> q++-- ---------------------------------------------------------------------------+-- The file: one JSON object per line, {"request": …, "answer": …}++load :: FilePath -> IO [(Value, Value)]+load file = do+  exists <- doesFileExist file+  if not exists+    then pure []+    else do+      contents <- LBS.readFile file+      pure [entry | line <- LBS.lines contents, not (LBS.null line), Just entry <- [parse line]]+  where+    parse line = do+      v <- fromAeson <$> J.decode line+      case v of+        Object kvs -> (,) <$> lookupField "request" kvs <*> lookupField "answer" kvs+        _ -> Nothing++append :: FilePath -> Value -> Value -> IO ()+append file key answer = withFile file AppendMode $ \h -> do+  T.hPutStrLn h (renderJson (Object [("request", key), ("answer", answer)]))+  hFlush h++-- ---------------------------------------------------------------------------+-- Keys++-- | Keys are compared in a canonical form: object keys sorted, whole numbers as+-- integers. Reading the file back through aeson reorders keys, and order+-- doesn't change which request it is.+canonical :: Value -> Value+canonical = \case+  Object kvs -> Object (sortOn fst [(k, canonical v) | (k, v) <- kvs])+  Array vs -> Array (map canonical vs)+  Number d | d == fromInteger (round d) -> Integer (round d)+  v -> v++turnKey :: Conversation -> Value+turnKey c =+  Object+    [ ("kind", String "turn")+    , ("path", Array [String (noteName n) | n <- path c])+    , ("instruction", String (instructionText (instruction c)))+    , ("state", state c)+    , ("stateSchema", jsonSchema (stateSchema c))+    , ("tools", Array [Object [("name", String (specName t)), ("description", String (specDescription t)), ("input", jsonSchema (specInput t))] | t <- tools c])+    , ("output", jsonSchema (output c))+    , ("history", Array (map exchange (history c)))+    ]+  where+    exchange = \case+      Called (Raw r) results -> Object [("called", r), ("results", Array [Object [("id", String i), ("result", toolResult res)] | (i, res) <- results])]+      Rejected (Raw r) problem -> Object [("rejected", r), ("problem", String problem)]+    toolResult = \case+      ToolOk v -> Object [("ok", v)]+      ToolFailed t -> Object [("failed", String t)]++judgeKey :: JudgeRequest -> Value+judgeKey r = Object [("kind", String "judgement"), ("state", requestState r), ("questions", Array (map spec (requestQuestions r)))]+  where+    spec = \case+      AskYesNo q -> Object [("yesNo", String q)]+      AskChoice q opts -> Object [("choice", String q), ("options", labelled opts)]+      AskScore q levels -> Object [("score", String q), ("levels", labelled levels)]+    labelled xs = Array [Object [("label", String l), ("description", maybe Null String d)] | (l, d) <- xs]++-- ---------------------------------------------------------------------------+-- Answers++encodeTurn :: Turn -> Value+encodeTurn (Turn (Raw r) a) = Object [("raw", r), ("action", act a)]+  where+    act = \case+      CallTools calls -> Object [("callTools", Array [Object [("id", String (callId c)), ("name", String (callName c)), ("input", callInput c)] | c <- calls])]+      Respond v -> Object [("respond", v)]++decodeTurn :: Value -> Maybe Turn+decodeTurn = \case+  Object kvs -> do+    r <- lookupField "raw" kvs+    a <- lookupField "action" kvs+    Turn (Raw r) <$> act a+  _ -> Nothing+  where+    act = \case+      Object [("respond", v)] -> Just (Respond v)+      Object [("callTools", Array calls)] -> CallTools <$> traverse call calls+      _ -> Nothing+    call = \case+      Object kvs -> ToolCall <$> text "id" kvs <*> text "name" kvs <*> lookupField "input" kvs+      _ -> Nothing+    text k kvs = case lookupField k kvs of+      Just (String t) -> Just t+      _ -> Nothing++encodeAnswers :: [Answer] -> Value+encodeAnswers = Array . map answer+  where+    answer = \case+      YesNoAnswer p -> Object [("yesNo", prob p)]+      ChoiceAnswer l ps c -> Object [("choice", String l), ("probabilities", Array [Array [String x, prob p] | (x, p) <- ps]), ("confidence", prob c)]+      ScoreAnswer pos ps c -> Object [("score", Number pos), ("probabilities", Array [Array [Integer (toInteger i), prob p] | (i, p) <- ps]), ("confidence", prob c)]+    prob = Integer . toInteger . basisPoints++decodeAnswers' :: Value -> Maybe [Answer]+decodeAnswers' = \case+  Array xs -> traverse answer xs+  _ -> Nothing+  where+    -- Look fields up by name: the file comes back through aeson, which+    -- reorders keys.+    answer = \case+      Object kvs+        | Just p <- lookupField "yesNo" kvs -> YesNoAnswer <$> prob p+        | Just (String l) <- lookupField "choice" kvs ->+            ChoiceAnswer l <$> (pairs label =<< lookupField "probabilities" kvs) <*> (prob =<< lookupField "confidence" kvs)+        | Just pos <- lookupField "score" kvs ->+            ScoreAnswer <$> number pos <*> (pairs index =<< lookupField "probabilities" kvs) <*> (prob =<< lookupField "confidence" kvs)+      _ -> Nothing+    pairs key = \case+      Array ps -> traverse (\case Array [k, p] -> (,) <$> key k <*> prob p; _ -> Nothing) ps+      _ -> Nothing+    label = \case+      String t -> Just t+      _ -> Nothing+    index = \case+      Integer i -> Just (fromInteger i)+      _ -> Nothing+    prob = \case+      Integer bp -> Just (fromBasisPoints (fromInteger bp / 10000))+      _ -> Nothing+    number = \case+      Number d -> Just d+      Integer n -> Just (fromInteger n)+      _ -> Nothing
+ test/Spec.hs view
@@ -0,0 +1,91 @@+module Main (main) where++import Agentic+import Agentic.IO+import Agentic.Scripted (alwaysYes, replyingWith, respond)+import Control.Exception (try)+import Data.IORef+import Data.Text (Text)+import GHC.Generics (Generic)+import System.Directory (getTemporaryDirectory, removeFile, doesFileExist)+import System.FilePath ((</>))+import Test.Hspec hiding (describe)+import qualified Test.Hspec++data Joke = Joke {setup :: Text, punchline :: Text}+  deriving (Generic, Show, Eq, Contract)++data Groan = Mild | Solid | Unbearable+  deriving (Generic, Show, Eq, Options)++joke :: Joke+joke = Joke "Why was the scarecrow promoted?" "He was outstanding in his field."++-- | A flow with one draft and one judgement.+flow :: Agentic IO Text (Joke, (YesNo, Choice Groan, Score Groan))+flow = draft @Joke "a joke about this" >>> (returnA &&& judge ((,,) <$> yesNo "Is it funny?" <*> choice "Reaction?" <*> score "Groaning?"))++-- | A runtime whose models count their calls.+counting :: IO (Runtime IO, IORef Int, IORef Int)+counting = do+  turns <- newIORef 0+  judgements <- newIORef 0+  let SystemTwo two = replyingWith (const (respond joke))+      SystemOne one = alwaysYes 0.8+  pure+    ( runtime+        { systemTwo = SystemTwo (\c -> modifyIORef turns (+ 1) >> two c)+        , systemOne = SystemOne (\r -> modifyIORef judgements (+ 1) >> one r)+        }+    , turns+    , judgements+    )++-- | A runtime whose models must not be called.+offline :: Runtime IO+offline =+  runtime+    { systemTwo = SystemTwo (const (fail "the model was called"))+    , systemOne = SystemOne (const (fail "Jev was called"))+    }++fresh :: String -> IO FilePath+fresh name = do+  dir <- getTemporaryDirectory+  let file = dir </> name+  exists <- doesFileExist file+  if exists then removeFile file else pure ()+  pure file++main :: IO ()+main = hspec $ Test.Hspec.describe "withStore" $ do+  it "records, then replays without calling the models" $ do+    file <- fresh "agentic-store-replay.jsonl"+    (live, turns, judgements) <- counting+    recording <- withStore Record file live+    recorded <- interpret recording flow "scarecrows"+    (,) <$> readIORef turns <*> readIORef judgements `shouldReturn` (1, 1)+    replaying <- withStore Replay file offline+    interpret replaying flow "scarecrows" `shouldReturn` recorded++  it "fails clearly when a replay asks something new" $ do+    file <- fresh "agentic-store-miss.jsonl"+    (live, _, _) <- counting+    recording <- withStore Record file live+    _ <- interpret recording flow "scarecrows"+    replaying <- withStore Replay file offline+    result <- try (interpret replaying flow "penguins")+    either (\(StoreMiss _ what) -> what) (const "no miss") result `shouldBe` "a turn of: a joke about this"++  it "replays what it has and records what it doesn't" $ do+    file <- fresh "agentic-store-both.jsonl"+    (live, turns, _) <- counting+    store <- withStore ReplayOrRecord file live+    _ <- interpret store flow "scarecrows"+    _ <- interpret store flow "scarecrows"+    readIORef turns `shouldReturn` 1+    _ <- interpret store flow "penguins"+    readIORef turns `shouldReturn` 2+    again <- withStore ReplayOrRecord file offline+    _ <- interpret again flow "penguins"+    pure ()