diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for agentic-aeson + +## 0.2.0.0 - 2026-10-01 + +First release of the v2 design. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/agentic-aeson.cabal b/agentic-aeson.cabal new file mode 100644 --- /dev/null +++ b/agentic-aeson.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.0 +name: agentic-aeson +version: 0.2.0.0 +synopsis: Conversions between agentic's values and aeson, and strict JSON Schema +description: + Shared by the agentic provider packages: converts the core's Value to and from aeson, and lowers contracts to the strict JSON Schema that providers' structured outputs accept, keeping field order and sharing repeated types through $defs. +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-aeson + +library + default-language: GHC2021 + default-extensions: LambdaCase OverloadedStrings + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: + Agentic.Aeson + Agentic.JsonSchema + build-depends: + , agentic ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , scientific >=0.3 && <0.4 + , text >=2.0 && <2.2 + , vector >=0.12 && <0.14 diff --git a/src/Agentic/Aeson.hs b/src/Agentic/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/Aeson.hs @@ -0,0 +1,33 @@ +-- | Conversions between the core's 'Agentic.Value.Value' and aeson's. +module Agentic.Aeson + ( toAeson + , fromAeson + ) where + +import qualified Agentic.Value as A +import qualified Data.Aeson as J +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Scientific (floatingOrInteger) +import qualified Data.Vector as Vector + +-- | The core's value as aeson's. Object keys keep no order once in aeson. +toAeson :: A.Value -> J.Value +toAeson = \case + A.Null -> J.Null + A.Bool b -> J.Bool b + A.Integer n -> J.Number (fromInteger n) + A.Number d -> J.Number (realToFrac d) + A.String s -> J.String s + A.Array vs -> J.Array (Vector.fromList (map toAeson vs)) + A.Object kvs -> J.Object (KeyMap.fromList [(Key.fromText k, toAeson v) | (k, v) <- kvs]) + +-- | Aeson's value as the core's. Whole numbers become integers. +fromAeson :: J.Value -> A.Value +fromAeson = \case + J.Null -> A.Null + J.Bool b -> A.Bool b + J.Number n -> either A.Number A.Integer (floatingOrInteger n) + J.String s -> A.String s + J.Array vs -> A.Array (map fromAeson (Vector.toList vs)) + J.Object o -> A.Object [(Key.toText k, fromAeson v) | (k, v) <- KeyMap.toList o] diff --git a/src/Agentic/JsonSchema.hs b/src/Agentic/JsonSchema.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/JsonSchema.hs @@ -0,0 +1,145 @@ +-- | Lowering the core's t'Schema' to the strict JSON Schema that providers' +-- structured outputs and strict tools accept. +-- +-- The result is the core's 'Value', not aeson's, because order matters: a +-- model writes an object's fields in the order its schema lists them, and a +-- record's field order is part of its meaning (a setup comes before its +-- punchline). aeson would sort the keys. Render with 'renderJson'. +module Agentic.JsonSchema + ( jsonSchema + , objectSchema + , schemaName + , wrap + , unwrap + ) where + +import Agentic.Schema +import Agentic.Value +import Data.Char (isAlphaNum) +import Data.List (nub) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T + +-- | A strict JSON Schema: every object lists all its fields as required and +-- forbids others; nullable fields may be null. Types are written out in full +-- wherever they appear; 'objectSchema' shares repeated ones. +jsonSchema :: Schema -> Value +jsonSchema = schemaWith [] + +-- | Like 'jsonSchema', but any schema named in @shared@ becomes a @$ref@ into +-- @$defs@. +schemaWith :: [Text] -> Schema -> Value +schemaWith shared s = case title s of + Just t | t `elem` shared -> Object [("$ref", String ("#/$defs/" <> t))] + _ -> definition shared s + +-- | A schema written out, though the schemas inside it may still be references. +definition :: [Text] -> Schema -> Value +definition shared s = withDescription (body (shape s)) + where + sub = schemaWith shared + withDescription = \case + Object kvs | Just d <- description -> Object (kvs <> [("description", String d)]) + v -> v + description = case catMaybes [doc s] <> map (\c -> "Must be " <> c <> ".") (checks s) of + [] -> Nothing + ds -> Just (T.intercalate " " ds) + body = \case + SObject fs -> object (map (\f -> (fieldName f, sub (fieldSchema f))) fs) + SSum vs -> Object [("anyOf", Array (map variant vs))] + SEnum ls + | all ((== Nothing) . snd) ls -> Object [typed "string", ("enum", Array (map (String . fst) ls))] + | otherwise -> Object [("anyOf", Array [constant l d | (l, d) <- ls])] + SArray inner -> Object [typed "array", ("items", sub inner)] + SNullable inner -> Object [("anyOf", Array [sub inner, Object [typed "null"]])] + SString format -> Object (typed "string" : maybe [] (\f -> [("format", String (formatName f))]) format) + SInteger -> Object [typed "integer"] + SNumber -> Object [typed "number"] + SBool -> Object [typed "boolean"] + SNull -> Object [typed "null"] + variant v = + let tagged = ("tag", Object [typed "string", ("const", String (variantTag v))]) + o = object (tagged : map (\f -> (fieldName f, sub (fieldSchema f))) (variantFields v)) + in case (o, variantDoc v) of + (Object kvs, Just d) -> Object (kvs <> [("description", String d)]) + _ -> o + constant l d = Object ([typed "string", ("const", String l)] <> maybe [] (\t -> [("description", String t)]) d) + typed :: Text -> (Text, Value) + typed t = ("type", String t) + +object :: [(Text, Value)] -> Value +object fields = + Object + [ ("type", String "object") + , ("properties", Object fields) + , ("required", Array (map (String . fst) fields)) + , ("additionalProperties", Bool False) + ] + +formatName :: Format -> Text +formatName = \case + DateTime -> "date-time" + Date -> "date" + Email -> "email" + Uri -> "uri" + Uuid -> "uuid" + +-- | Does this schema need wrapping to be a top-level object? +wrap :: Schema -> Bool +wrap s = case shape s of + SObject _ -> False + _ -> True + +-- | A top-level object schema: the schema itself if it's an object, or an +-- object with a single @value@ field holding it. A named type that appears more +-- than once, identically, is written once under @$defs@ and referenced. +-- +-- TBD: Recursively defined schemas will hang here. A recursive type's derived +-- schema contains itself, so walking it never ends. +objectSchema :: Schema -> Value +objectSchema s = case root of + Object kvs | not (null defs) -> Object (kvs <> [("$defs", Object defs)]) + other -> other + where + root + | wrap s = object [("value", schemaWith shared s)] + | otherwise = definition shared s + shared = sharedNames s + defs = [(t, definition shared d) | t <- shared, Just d <- [lookup t named']] + named' = [(t, d) | d <- nested s, Just t <- [title d]] + +-- | Names of the types inside a schema (not the schema itself) that appear more +-- than once and are identical everywhere they appear, in order of appearance. +sharedNames :: Schema -> [Text] +sharedNames s = [t | t <- nub names, uses t >= 2, length (nub [d | d <- inside, title d == Just t]) == 1] + where + inside = nested s + names = catMaybes (map title inside) + uses t = length (filter ((== Just t) . title) inside) + +-- | Every schema nested inside this one, outermost first. +nested :: Schema -> [Schema] +nested s = concatMap (\c -> c : nested c) (children (shape s)) + where + children = \case + SObject fs -> map fieldSchema fs + SSum vs -> concatMap (map fieldSchema . variantFields) vs + SArray c -> [c] + SNullable c -> [c] + _ -> [] + +-- | A name for the schema, for providers that ask for one: the type's name with +-- anything but letters, digits, @_@ and @-@ dropped, or @output@. +schemaName :: Schema -> Text +schemaName s = case T.intercalate "_" (filter (not . T.null) (T.split (not . valid) (maybe "" id (title s)))) of + "" -> "output" + n -> T.take 64 n + where + valid c = isAlphaNum c || c == '_' || c == '-' + +-- | Undo the wrapping 'objectSchema' adds, on a value from the provider. +unwrap :: Schema -> Value -> Value +unwrap s v + | wrap s, Object kvs <- v, Just inner <- lookup "value" kvs = inner + | otherwise = v