plexus-synapse (empty) → 0.3.0.0
raw patch · 32 files changed
+7421/−0 lines, 32 filesdep +aesondep +aeson-prettydep +array
Dependencies added: aeson, aeson-pretty, array, async, base, bytestring, containers, directory, filepath, hashable, hspec, mtl, mustache, network, optparse-applicative, plexus-protocol, plexus-synapse, prettyprinter, process, regex-tdfa, scientific, stm, streaming, text, time, transformers, unordered-containers, vector, websockets, yaml
Files
- app/Main.hs +800/−0
- examples/SchemaDiscovery.hs +114/−0
- plexus-synapse.cabal +196/−0
- src/Synapse/Algebra/Navigate.hs +102/−0
- src/Synapse/Algebra/Recursion.hs +197/−0
- src/Synapse/Algebra/Render.hs +207/−0
- src/Synapse/Algebra/Walk.hs +149/−0
- src/Synapse/Backend/Discovery.hs +350/−0
- src/Synapse/Bidir.hs +268/−0
- src/Synapse/CLI/Help.hs +271/−0
- src/Synapse/CLI/Parse.hs +345/−0
- src/Synapse/CLI/Similarity.hs +68/−0
- src/Synapse/CLI/Support.hs +273/−0
- src/Synapse/CLI/Template.hs +477/−0
- src/Synapse/CLI/Transform.hs +379/−0
- src/Synapse/Cache.hs +27/−0
- src/Synapse/IR/Builder.hs +716/−0
- src/Synapse/IR/Types.hs +321/−0
- src/Synapse/Monad.hs +208/−0
- src/Synapse/Renderer.hs +339/−0
- src/Synapse/Schema/Functor.hs +99/−0
- src/Synapse/Schema/Types.hs +133/−0
- src/Synapse/Self/Commands.hs +99/−0
- src/Synapse/Self/Examples.hs +101/−0
- src/Synapse/Self/Pattern.hs +49/−0
- src/Synapse/Self/Template.hs +300/−0
- src/Synapse/Transport.hs +237/−0
- test/CLISpec.hs +74/−0
- test/IRSpec.hs +247/−0
- test/ParseSpec.hs +81/−0
- test/PathNormalizationSpec.hs +128/−0
- test/TypeRefJson.hs +66/−0
+ app/Main.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Synapse CLI - Algebraic Implementation+--+-- This executable uses the categorical machinery:+-- - Effect stack (SynapseM) with caching and cycle detection+-- - Reified algebras for navigation, rendering, completion+-- - Proper error handling+--+-- CLI Structure:+-- synapse [OPTIONS] <backend> <path...> [--param value ...]+--+-- Options must appear BEFORE the backend. Everything after the backend+-- is passed through for method invocation.+module Main where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Aeson+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Encoding as TE+import Options.Applicative+import Data.Version (showVersion)+import qualified Paths_plexus_synapse as Meta+import System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr, hFlush, stdout)+++import Synapse.Schema.Types+import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnv, runSynapseM, throwNav, throwTransport, throwParse, throwBackend)+import Synapse.Algebra.Navigate+import Synapse.Algebra.Render (renderSchema)+import Synapse.CLI.Help (renderMethodHelp)+import Synapse.CLI.Parse (parseParams)+import qualified Synapse.CLI.Parse as Parse+import Synapse.IR.Types (IR, irMethods, MethodDef)+import qualified Data.Map.Strict as Map+import qualified Synapse.CLI.Template as TemplateIR+import Synapse.Transport+import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest)+import Plexus.Types (Response(..))+import Synapse.CLI.Transform (mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults)+import Synapse.IR.Builder (buildIR)+import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath)+import System.Directory (createDirectoryIfMissing, getHomeDirectory)+import System.FilePath ((</>))+import qualified Synapse.Self.Commands as Self+import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt)++-- ============================================================================+-- Types+-- ============================================================================++-- | Synapse-level options (must appear before backend)+-- Controls connection settings and output format+data SynapseOpts = SynapseOpts+ { soHost :: Text -- ^ Registry host for discovery+ , soPort :: Int -- ^ Registry port for discovery+ , soJson :: Bool -- ^ Output raw JSON stream items+ , soRaw :: Bool -- ^ Output raw content (no templates)+ , soDryRun :: Bool -- ^ Show request without sending+ , soSchema :: Bool -- ^ Fetch raw schema JSON+ , soGenerate :: Bool -- ^ Generate templates from IR+ , soEmitIR :: Bool -- ^ Emit IR for code generation+ , soParams :: Maybe Text -- ^ JSON params via -p+ , soRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough+ , soGeneratorInfo :: [Text] -- ^ Generator tool info (tool:version pairs)+ , soBidirMode :: Maybe Text -- ^ Bidirectional mode override+ , soBidirCmd :: Maybe Text -- ^ Bidirectional subprocess command (--bidir-cmd)+ }+ deriving Show++-- | Full CLI arguments after two-phase parsing+data Args = Args+ { argOpts :: SynapseOpts -- ^ Synapse-level options+ , argBackend :: Maybe Text -- ^ Backend name (first positional)+ , argPath :: [Text] -- ^ Path segments and --key value params (raw)+ }+ deriving Show+++-- ============================================================================+-- Constants+-- ============================================================================++defaultHost :: Text+defaultHost = "127.0.0.1"++defaultPort :: Int+defaultPort = 4444++-- ============================================================================+-- Argument Splitting+-- ============================================================================+-- Main+-- ============================================================================++main :: IO ()+main = do+ args <- execParser argsInfo+ let opts = argOpts args+ -- Use specified host/port for registry discovery+ let discovery = registryDiscovery (soHost opts) (soPort opts)++ -- Get the backend at the connection point (host:port)+ -- If it has a registry plugin, that's used for discovering other backends+ maybeBackend <- getBackendAt (soHost opts) (soPort opts)+ let hostBackend = maybe "plexus" id maybeBackend++ case argBackend args of+ Nothing+ -- Suppress banner for data output modes+ | soEmitIR opts || soSchema opts || soJson opts || soRaw opts ->+ runWithDiscovery discovery hostBackend args+ | otherwise -> do+ -- No backend specified, show available backends+ TIO.putStr cliHeader+ backends <- discoverBackends discovery+ -- Ping backends to check if they're reachable+ backendsWithStatus <- pingBackends backends+ TIO.putStrLn "\nAvailable backends:"+ mapM_ printBackend backendsWithStatus+ TIO.putStrLn "\nUsage: synapse <backend> [command...]"+ Just backend+ -- Handle --help/-h if it somehow ends up as the backend+ | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader+ -- Handle _self meta-commands (use discovered primary backend)+ | backend == "_self" -> runWithDiscovery discovery hostBackend args+ | otherwise -> runWithDiscovery discovery backend args++-- | Print a backend in the list+printBackend :: Backend -> IO ()+printBackend b = do+ let nameField = T.justifyLeft 15 ' ' (backendName b)+ let hostPort = backendHost b <> ":" <> T.pack (show (backendPort b))+ let status = case backendReachable b of+ Just True -> " [OK]"+ Just False -> " [UNREACHABLE]"+ Nothing -> ""+ let desc = if T.null (backendDescription b)+ then ""+ else " - " <> backendDescription b+ TIO.putStrLn $ " " <> nameField <> hostPort <> status <> desc++-- | Run a Hub command with backend discovery+runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO ()+runWithDiscovery discovery backendName args = do+ let opts = argOpts args+ -- Try to discover backend info+ maybeBackend <- getBackendInfo discovery backendName++ case maybeBackend of+ Just backend -> do+ -- Always use discovered host/port from registry+ -- The -H/-P flags specify where to find the registry, not the target backend+ run backendName (backendHost backend) (backendPort backend) args+ Nothing -> do+ -- Backend not found in registry - gather available backends and show error+ backends <- discoverBackends discovery+ backendsWithStatus <- pingBackends backends+ env <- initEnv (soHost opts) (soPort opts) backendName+ result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus)+ case result of+ Left err -> do+ hPutStrLn stderr $ renderError err+ exitFailure+ Right () -> exitSuccess++-- | Run a Hub command with specified backend and connection details+run :: Text -> Text -> Int -> Args -> IO ()+run backend host port args = do+ env <- initEnv host port backend+ rendererCfg <- defaultRendererConfig+ result <- runSynapseM env (dispatch args rendererCfg)+ case result of+ Left err -> do+ hPutStrLn stderr $ renderError err+ exitFailure+ Right () -> exitSuccess++-- | Dispatch based on navigation result+dispatch :: Args -> RendererConfig -> SynapseM ()+dispatch Args{argOpts = SynapseOpts{..}, argBackend, argPath} rendererCfg = do+ -- Check for _self commands first (before anything else)+ case argBackend of+ Just "_self" -> do+ -- _self meta-command: parse subcommand and rest from argPath+ let (pathSegs, rawParams, _) = parsePathAndParams argPath+ case pathSegs of+ (subcommand : rest) -> do+ Self.dispatch subcommand rest rawParams+ return ()+ [] -> do+ -- No subcommand provided, show help+ Self.showHelp+ return ()++ -- Normal dispatch+ _ -> do+ -- Mode 1: Raw JSON-RPC passthrough+ case soRpc of+ Just rpcJson -> do+ case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of+ Left err -> throwParse $ T.pack err+ Right rpcReq -> do+ items <- invokeRawRpc rpcReq+ liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items+ return ()++ Nothing -> do+ -- Parse path and inline params (--key value pairs)+ let (pathSegs, rawParams, helpRequested) = parsePathAndParams argPath++ -- Normal Plexus RPC routing+ -- Apply parameter transformations (path expansion, env vars)+ transformEnv <- liftIO mkTransformEnv+ inlineParams <- liftIO $ transformParams transformEnv defaultTransformers rawParams++ -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request)+ if not (null pathSegs) && head pathSegs == "respond"+ then handleRespondCommand rawParams++ -- Mode 2: Schema request+ else if soSchema+ then do+ -- Try to navigate and determine if last segment is a method+ schemaResult <- fetchSchemaForPath pathSegs+ case schemaResult of+ Left err -> throwNav $ FetchError err pathSegs+ Right val -> liftIO $ LBS.putStrLn $ encode val++ -- Mode 3: Generate templates (IR-driven approach)+ else if soGenerate+ then do+ homeDir <- liftIO getHomeDirectory+ let baseDir = homeDir </> ".config" </> "synapse" </> "templates"+ writeAndLog gt = do+ writeGeneratedTemplateIR baseDir gt+ TIO.putStrLn $ " " <> T.pack (TemplateIR.gtPath gt)+ liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."+ count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs+ liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates"++ -- Mode 4: Emit IR for code generation+ else if soEmitIR+ then do+ ir <- buildIR soGeneratorInfo pathSegs+ liftIO $ LBS.putStrLn $ encode ir++ else do+ -- Mode 5: Normal navigation+ if null pathSegs+ then do+ rootSchema <- navigate []+ case rootSchema of+ ViewPlugin schema _ -> liftIO $ do+ TIO.putStr cliHeader+ TIO.putStr "\n\n"+ TIO.putStr $ renderSchema schema+ _ -> pure ()+ else do+ -- Navigate to target+ view <- navigate pathSegs+ case view of+ -- Landed on a plugin: show help+ ViewPlugin schema _ ->+ liftIO $ TIO.putStr $ renderSchema schema++ -- Landed on a method: invoke or show help+ ViewMethod method path -> do+ -- Build IR for this method's namespace+ ir <- buildIR soGeneratorInfo (init path)+ let fullPath = T.intercalate "." path++ -- If --help was explicitly requested, show help and exit+ if helpRequested+ then do+ case Map.lookup fullPath (irMethods ir) of+ Just methodDef ->+ liftIO $ TIO.putStr $ renderMethodHelp ir methodDef+ Nothing ->+ liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method+ else do+ -- Build params: use IR-driven parsing for inline params+ let schemaDefaults = extractSchemaDefaults method+ userParams <- case soParams of+ -- -p JSON: parse as raw JSON (bypass IR parsing)+ Just jsonStr ->+ case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of+ Left err -> throwParse $ T.pack err+ Right p -> pure p+ Nothing+ | not (null inlineParams) ->+ -- Use IR-driven parsing for inline params+ case Map.lookup fullPath (irMethods ir) of+ Just methodDef -> do+ -- Inject boolean defaults for flags without values+ let paramsWithBools = injectBooleanDefaults ir methodDef inlineParams+ -- Inject smart defaults for missing required params (e.g., --path defaults to cwd)+ paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools+ case parseParams ir methodDef paramsWithDefaults of+ Right p -> pure p+ Left errs -> do+ liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs+ throwParse "Parameter parsing failed"+ Nothing ->+ -- Fallback to flat object if method not in IR+ pure $ buildParamsObject inlineParams+ | otherwise -> pure $ object []+ -- Merge: user params override schema defaults+ let params = mergeParams schemaDefaults userParams++ if soDryRun+ then do+ backend <- asks seBackend+ liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params+ -- Show help when: method has required params AND user provided no params+ else if hasRequiredParams method && userParams == object [] && null inlineParams+ then do+ -- Render help from IR+ case Map.lookup fullPath (irMethods ir) of+ Just methodDef ->+ liftIO $ TIO.putStr $ renderMethodHelp ir methodDef+ Nothing ->+ -- Fallback: method not in IR, use basic info+ liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method+ else invokeMethod path params+ where+ handleRespondCommand :: [(Text, Text)] -> SynapseM ()+ handleRespondCommand params = do+ let mRequestId = lookup "request_id" params+ mResponseStr = lookup "response" params+ case (mRequestId, mResponseStr) of+ (Nothing, _) -> throwParse "Missing --request-id for respond subcommand"+ (_, Nothing) -> throwParse "Missing --response for respond subcommand"+ (Just requestId, Just responseStr) ->+ case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of+ Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err+ Right (resp :: Response Value) -> sendResponse requestId resp++ invokeMethod path params = do+ let namespacePath = init path -- path without method name+ let methodName' = last path+ -- Set method path hint for template resolution+ let rendererCfg' = withMethodPath rendererCfg path+ -- Determine bidirectional mode (--bidir-cmd takes precedence)+ bidirMode <- liftIO $ case soBidirCmd of+ Just cmd -> pure $ BidirCmd cmd+ Nothing -> case soBidirMode of+ Just modeStr -> case parseBidirMode modeStr of+ Just mode -> pure mode+ Nothing -> do+ TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect"+ detectBidirMode+ Nothing -> detectBidirMode+ -- Use bidirectional streaming handler+ invokeStreamingWithBidir+ namespacePath+ methodName'+ params+ (printResult soJson soRaw rendererCfg')+ (handleBidirRequest bidirMode)++ -- Extract default values from JSON Schema properties+ -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...}+ extractSchemaDefaults :: MethodSchema -> Value+ extractSchemaDefaults m = case methodParams m of+ Nothing -> object []+ Just (Object o) -> case KM.lookup "properties" o of+ Just (Object props) -> object+ [ (k, defaultVal)+ | (k, propSchema) <- KM.toList props+ , Object propObj <- [propSchema]+ , Just defaultVal <- [KM.lookup "default" propObj]+ ]+ _ -> object []+ Just _ -> object []++ -- Merge two JSON objects: right takes precedence over left+ mergeParams :: Value -> Value -> Value+ mergeParams (Object defaults) (Object user) =+ Object (KM.union user defaults) -- union prefers first arg on conflict+ mergeParams _ user = user -- if defaults aren't an object, just use user params++ -- Check if method has required parameters+ hasRequiredParams :: MethodSchema -> Bool+ hasRequiredParams m = case methodParams m of+ Nothing -> False+ Just (Object o) -> case KM.lookup "required" o of+ Just (Array arr) -> not (null arr)+ _ -> False+ Just _ -> False++ -- Fetch schema for a path, detecting if last segment is a method+ -- Uses navigate to determine what type of schema to fetch+ fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value)+ fetchSchemaForPath segs = do+ view <- navigate segs+ case view of+ ViewPlugin schema _ -> pure $ Right $ toJSON schema+ ViewMethod method path -> do+ -- Use method-specific schema query for detailed method info+ let parentPath = init path+ methodName' = last path+ detailedMethod <- fetchMethodSchema parentPath methodName'+ pure $ Right $ toJSON detailedMethod++ -- Invoke raw JSON-RPC request+ invokeRawRpc :: Value -> SynapseM [HubStreamItem]+ invokeRawRpc rpcReq = do+ case rpcReq of+ Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of+ (Just (String method), Just params) -> invokeRaw method params+ (Just (String method), Nothing) -> invokeRaw method (object [])+ _ -> throwParse "JSON-RPC must have 'method' field"+ _ -> throwParse "JSON-RPC must be an object"++-- | Parse path segments and --key value params+-- Returns (path segments, [(key, value)] params, help requested)+-- Example: ["echo", "once", "--message", "hello", "--count", "3"]+-- -> (["echo", "once"], [("message", "hello"), ("count", "3")], False)+-- Example: ["echo", "once", "--help"]+-- -> (["echo", "once"], [], True)+parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool)+parsePathAndParams = go [] [] False+ where+ go path params helpReq [] = (reverse path, reverse params, helpReq)+ go path params helpReq (x:xs)+ -- --help flag: mark help requested, don't add as param+ | x == "--help" || x == "-h" =+ go path params True xs+ -- --key value pair (value must not start with --)+ | Just key <- T.stripPrefix "--" x+ , not (T.null key)+ , (val:rest) <- xs+ , not (T.isPrefixOf "--" val) =+ let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case+ in go path ((normalizedKey, val) : params) helpReq rest+ -- --key with no value or next arg is another flag (boolean flag)+ | Just key <- T.stripPrefix "--" x+ , not (T.null key) =+ let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case+ in go path ((normalizedKey, "") : params) helpReq xs+ -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat)+ | otherwise =+ let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x+ in go (reverse segments ++ path) params helpReq xs++-- | Build JSON object from key-value pairs+buildParamsObject :: [(Text, Text)] -> Value+buildParamsObject pairs = object+ [ (K.fromText k, inferValue v) | (k, v) <- pairs ]+ where+ -- Try to infer the JSON type from the string value+ inferValue :: Text -> Value+ inferValue t+ | t == "true" = Bool True+ | t == "false" = Bool False+ | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n)+ | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n)+ | otherwise = String t++readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing++-- | ASCII splash logo+splash :: Text+splash = T.unlines+ [ ""+ , "███████╗██╗ ██╗███╗ ██╗ █████╗ ██████╗ ███████╗███████╗"+ , "██╔════╝╚██╗ ██╔╝████╗ ██║██╔══██╗██╔══██╗██╔════╝██╔════╝"+ , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗ "+ , "╚════██║ ╚██╔╝ ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝ "+ , "███████║ ██║ ██║ ╚████║██║ ██║██║ ███████║███████╗"+ , "╚══════╝ ╚═╝ ╚═╝ ╚═══╝╚═╝ ╚═╝╚═╝ ╚══════╝╚══════╝"+ , ""+ ]++-- | Get CLI help text from optparse-applicative+cliHeader :: Text+cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> selfHelp+ where+ failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty+ selfHelp = T.unlines+ [ ""+ , "Meta-commands (local, no RPC):"+ , ""+ , " synapse _self template"+ , " Manage Mustache templates (CRUD operations)"+ , ""+ , " Subcommands:"+ , " list [pattern] - List existing templates"+ , " show <method> - Display template content"+ , " generate [pattern] - Generate new templates from IR"+ , " delete <pattern> - Delete templates"+ , " reload - Clear template cache"+ , ""+ , " Examples:"+ , " synapse _self template list"+ , " synapse _self template show cone.chat"+ , " synapse _self template generate 'plexus.cone.*'"+ , ""+ ]++-- | Render an error for display+renderError :: SynapseError -> String+renderError = \case+ NavError (NotFound seg path maybeSchema) ->+ let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path+ in case maybeSchema of+ Nothing -> baseMsg+ Just schema ->+ let methods = psMethods schema+ children = pluginChildren schema+ suggestions = if null methods && null children+ then ""+ else "\n\nAvailable commands:"+ <> renderMethods methods+ <> renderChildren children+ in baseMsg <> suggestions+ NavError (MethodNotTerminal seg path) ->+ "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path+ NavError (Cycle hash path) ->+ "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path+ NavError (FetchError msg path) ->+ "Fetch error at " <> showPath path <> ": " <> T.unpack msg+ TransportError msg ->+ "Transport error: " <> T.unpack msg+ TransportErrorContext ctx ->+ renderTransportError ctx+ ParseError msg ->+ "Parse error: " <> T.unpack msg+ ValidationError msg ->+ "Validation error: " <> T.unpack msg+ BackendError errorType backends ->+ case errorType of+ BackendNotFound name ->+ "Backend not found: '" <> T.unpack name <> "'"+ <> renderBackendList backends+ BackendUnreachable name ->+ "Backend unreachable: '" <> T.unpack name <> "'"+ <> renderBackendList backends+ NoBackendsAvailable ->+ "No backends available"+ <> renderBackendList backends+ where+ showPath [] = "root"+ showPath p = T.unpack $ T.intercalate "." p++ renderMethods [] = ""+ renderMethods methods =+ let header = "\n\n Methods:"+ methodLines = map renderMethod methods+ in header <> concat methodLines++ renderMethod method =+ let name = T.unpack $ methodName method+ desc = T.unpack $ methodDescription method+ padding = 20+ namePadded = name <> replicate (max 1 (padding - length name)) ' '+ in "\n " <> namePadded <> desc++ renderChildren [] = ""+ renderChildren children =+ let header = "\n\n Child plugins:"+ childLines = map renderChild children+ in header <> concat childLines++ renderChild child =+ let name = T.unpack $ csNamespace child+ desc = T.unpack $ csDescription child+ padding = 20+ namePadded = name <> replicate (max 1 (padding - length name)) ' '+ in "\n " <> namePadded <> desc++ renderBackendList [] = "\n\nNo backends available."+ renderBackendList backends =+ let header = "\n\nAvailable backends:"+ backendLines = map renderBackendLine backends+ usageHint = "\n\nUsage: synapse <backend> [command...]"+ in header <> concat backendLines <> usageHint++ renderBackendLine backend =+ let name = T.unpack $ backendName backend+ nameField = name <> replicate (max 1 (15 - length name)) ' '+ hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend))+ status = case backendReachable backend of+ Just True -> " [OK]"+ Just False -> " [UNREACHABLE]"+ Nothing -> ""+ desc = if T.null (backendDescription backend)+ then ""+ else " - " <> T.unpack (backendDescription backend)+ in "\n " <> nameField <> hostPort <> status <> desc++-- | Render transport error with context+renderTransportError :: TransportContext -> String+renderTransportError TransportContext{..} = case tcCategory of+ ConnectionRefused ->+ "Connection refused\n\n" <>+ "Backend: " <> T.unpack tcBackend <> "\n" <>+ "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <>+ "Path: " <> showPath tcPath <> "\n\n" <>+ "Troubleshooting:\n" <>+ " - Check if the backend is running\n" <>+ " - Verify host (-H) and port (-P) settings\n" <>+ " - Run 'synapse' (no args) to list backends"++ ConnectionTimeout ->+ "Connection timeout\n\n" <>+ "Backend: " <> T.unpack tcBackend <> " @ " <>+ T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <>+ "The server may be overloaded or network latency is high\n" <>+ "Error: " <> T.unpack tcMessage++ ProtocolError ->+ "Protocol error\n\n" <>+ "Backend: " <> T.unpack tcBackend <> "\n" <>+ "This may indicate a version mismatch\n\n" <>+ "Error: " <> T.unpack tcMessage++ UnknownTransportError ->+ "Transport error: " <> T.unpack tcMessage <> "\n\n" <>+ "Backend: " <> T.unpack tcBackend <> " @ " <>+ T.unpack tcHost <> ":" <> show tcPort+ where+ showPath [] = "root"+ showPath p = T.unpack $ T.intercalate "." p++-- | Render a parse error for display+renderParseError :: Parse.ParseError -> String+renderParseError = \case+ Parse.UnknownParam name suggestions ->+ "Unknown parameter: --" <> T.unpack name <>+ case suggestions of+ [] -> ""+ [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?"+ ss -> "\n\nDid you mean one of:\n" <>+ unlines [" --" <> T.unpack s | s <- ss]+ Parse.MissingRequired name ->+ "Missing required parameter: --" <> T.unpack name+ Parse.InvalidValue name reason ->+ "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason+ Parse.AmbiguousVariant name variants ->+ "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants)+ Parse.MissingDiscriminator param field ->+ "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field+ Parse.UnknownVariant param value valid suggestions ->+ "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <>+ "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <>+ case suggestions of+ [] -> ""+ [s] -> "\n\nDid you mean: " <> T.unpack s <> "?"+ ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?"+ Parse.TypeNotFound name ->+ "Type not found in IR: " <> T.unpack name+++-- | Write a generated template to disk (no logging)+writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO ()+writeGeneratedTemplateIR baseDir gt = do+ let fullPath = baseDir </> TemplateIR.gtPath gt+ createDirectoryIfMissing True (baseDir </> T.unpack (TemplateIR.gtNamespace gt))+ TIO.writeFile fullPath (TemplateIR.gtTemplate gt)++-- | Encode a dry-run request+encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString+encodeDryRun backend namespacePath method params =+ let fullPath = if null namespacePath then [backend] else namespacePath+ dotPath = T.intercalate "." (fullPath ++ [method])+ in encode $ object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= (1 :: Int)+ , "method" .= (backend <> ".call")+ , "params" .= object+ [ "method" .= dotPath+ , "params" .= params+ ]+ ]++-- | Print a stream result+-- soJson: output raw JSON stream items+-- soRaw: skip template rendering, just output content JSON+-- otherwise: try template rendering, fall back to content JSON+printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO ()+printResult True _ _ item = LBS.putStrLn $ encode item+printResult _ True _ item = case item of+ -- Raw mode: just output the content+ HubData _ _ _ dat -> do+ LBS.putStrLn $ encode dat+ hFlush stdout+ HubProgress _ _ msg _ -> do+ TIO.putStr msg+ TIO.putStr "\r"+ hFlush stdout+ HubError _ _ err _ ->+ hPutStrLn stderr $ "Error: " <> T.unpack err+ _ -> pure ()+printResult _ _ cfg item = do+ -- Template mode: try to render with template+ mRendered <- renderItem cfg item+ case mRendered of+ Just text+ | T.null (T.strip text) -> pure ()+ | otherwise -> do+ TIO.putStr text+ hFlush stdout+ Nothing -> case item of+ -- Fallback to pretty-printed content+ HubData _ _ _ dat -> do+ TIO.putStrLn $ prettyValue dat+ hFlush stdout+ HubProgress _ _ msg _ -> do+ TIO.putStr msg+ TIO.putStr "\r"+ hFlush stdout+ HubError _ _ err _ ->+ hPutStrLn stderr $ "Error: " <> T.unpack err+ _ -> pure ()++-- ============================================================================+-- Argument Parsing (Synapse Options Only)+-- ============================================================================++-- | Parser for synapse-level options only+-- Backend and path are handled separately after arg splitting+argsInfo :: ParserInfo Args+argsInfo = info (argsParser <**> versionOption <**> helper)+ ( fullDesc+ <> header "synapse - Algebraic CLI for Hub"+ <> progDesc "synapse [OPTIONS] <backend> <path...> [--param value ...]"+ <> noIntersperse -- Stop option parsing at first positional arg+ )+ where+ versionOption = infoOption (showVersion Meta.version)+ ( long "version" <> short 'V' <> help "Show version" )++argsParser :: Parser Args+argsParser = Args <$> optsParser <*> backendParser <*> restParser+ where+ backendParser = optional $ T.pack <$> argument str+ ( metavar "BACKEND"+ <> help "Backend name (e.g., plexus, registry-hub)" )++ restParser = many $ T.pack <$> argument str+ ( metavar "PATH... [--param value ...]"+ <> help "Path and method parameters (passed through)" )++optsParser :: Parser SynapseOpts+optsParser = do+ soHost <- T.pack <$> strOption+ ( long "host" <> short 'H' <> metavar "HOST"+ <> value (T.unpack defaultHost)+ <> help "Registry/discovery host (default: 127.0.0.1)" )+ soPort <- option auto+ ( long "port" <> short 'P' <> metavar "PORT"+ <> value defaultPort+ <> help "Registry/discovery port (default: 4444)" )+ soJson <- switch+ ( long "json" <> short 'j'+ <> help "Output raw JSON stream items" )+ soRaw <- switch+ ( long "raw"+ <> help "Output raw content JSON (skip templates)" )+ soDryRun <- switch+ ( long "dry-run" <> short 'n'+ <> help "Show JSON-RPC request without sending" )+ soSchema <- switch+ ( long "schema" <> short 's'+ <> help "Fetch raw schema JSON for path" )+ soGenerate <- switch+ ( long "generate-templates" <> short 'g'+ <> help "Generate mustache templates from IR" )+ soEmitIR <- switch+ ( long "emit-ir" <> short 'i'+ <> help "Emit IR for code generation (JSON)" )+ soParams <- optional $ T.pack <$> strOption+ ( long "params" <> short 'p' <> metavar "JSON"+ <> help "Method parameters as JSON object" )+ soRpc <- optional $ T.pack <$> strOption+ ( long "rpc" <> short 'r' <> metavar "JSON"+ <> help "Raw JSON-RPC request (bypass navigation)" )+ soGeneratorInfo <- many $ T.pack <$> strOption+ ( long "generator-info" <> metavar "TOOL:VERSION"+ <> help "Generator tool version info (can be specified multiple times)" )+ soBidirMode <- optional $ T.pack <$> strOption+ ( long "bidir-mode" <> short 'b' <> metavar "MODE"+ <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" )+ soBidirCmd <- optional $ T.pack <$> strOption+ ( long "bidir-cmd" <> metavar "CMD"+ <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" )+ pure SynapseOpts{..}
+ examples/SchemaDiscovery.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Demonstrates the two-call schema discovery pattern+--+-- 1. Call substrate.schema → get list of activations+-- 2. For each activation, call substrate.activation_schema → get method schemas+--+-- The ActivationInfo structure drives both:+-- - CLI subcommand generation (arbor, cone, health)+-- - Schema enrichment requests (fetch enriched schema for each namespace)++module Main where++import Data.Aeson (Value, encode, toJSON)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Streaming.Prelude as S++import Plexus (connect, disconnect, defaultConfig)+import Substrate.Client (SubstrateConnection, substrateRpc)+import Plexus.Schema+ ( PlexusSchema(..)+ , PlexusSchemaEvent(..)+ , ActivationInfo(..)+ , EnrichedSchema(..)+ , ActivationSchemaEvent(..)+ , extractSchemaEvent+ , extractActivationSchemaEvent+ )++main :: IO ()+main = do+ putStrLn "=== Schema Discovery Demo ==="+ putStrLn ""++ conn <- connect defaultConfig++ -- STEP 1: Discover all activations+ putStrLn "Step 1: Calling substrate.schema to discover activations..."+ mSchema <- S.head_ $ S.mapMaybe extractSchemaEvent $+ substrateRpc conn "substrate.schema" (toJSON ([] :: [Value]))++ case mSchema of+ Nothing -> putStrLn "Failed to get schema"+ Just (SchemaError err) -> T.putStrLn $ "Schema error: " <> err+ Just (SchemaData schema) -> do+ putStrLn $ "Found " <> show (length (schemaActivations schema)) <> " activations"+ putStrLn ""++ -- For each activation, show what we'd do+ mapM_ (demonstrateActivation conn) (schemaActivations schema)++ disconnect conn++-- | Demonstrate how an ActivationInfo drives both CLI and schema requests+demonstrateActivation :: SubstrateConnection -> ActivationInfo -> IO ()+demonstrateActivation plexusConn act = do+ let ns = activationNamespace act+ methods = activationMethods act++ putStrLn $ "Activation: " <> T.unpack ns+ putStrLn $ " Description: " <> T.unpack (activationDescription act)+ putStrLn $ " Methods: " <> show (length methods)++ -- STEP 2: Use the namespace to request enriched schema+ putStrLn $ " → Requesting enriched schema for '" <> T.unpack ns <> "'..."++ mEnriched <- S.head_ $ S.mapMaybe extractActivationSchemaEvent $+ substrateRpc plexusConn "substrate.activation_schema" (toJSON [ns])++ case mEnriched of+ Nothing -> putStrLn " Failed to get enriched schema"+ Just (ActivationSchemaError err) ->+ T.putStrLn $ " Schema error: " <> err+ Just (ActivationSchemaData enriched) -> do+ let variantCount = maybe 0 length (schemaOneOf enriched)+ putStrLn $ " ✓ Got enriched schema with " <> show variantCount <> " method variants"++ -- Show the mapping: methods[i] corresponds to oneOf[i]+ putStrLn " Mapping (index-based):"+ mapM_ (\(idx, method) ->+ putStrLn $ " [" <> show idx <> "] " <> T.unpack method)+ (zip [0..] methods)++ putStrLn ""++ -- This demonstrates:+ -- 1. ActivationInfo.namespace → used for substrate.activation_schema RPC+ -- 2. ActivationInfo.methods → used to know which method corresponds to which oneOf variant+ -- 3. Same structure drives CLI: "symbols-dyn <namespace> <method>"++-- | The key insight: ActivationInfo is the source of truth for both+--+-- For CLI generation:+-- - activationNamespace → subcommand name ("arbor")+-- - activationMethods → sub-subcommand names ("tree-create", "tree-list")+--+-- For schema enrichment:+-- - activationNamespace → RPC parameter: substrate.activation_schema("arbor")+-- - activationMethods[i] → maps to enrichedSchema.oneOf[i]+--+-- This creates a direct correspondence:+--+-- CLI Command | Schema Lookup+-- -------------------------|----------------------------------+-- arbor tree-create | enriched["arbor"].oneOf[0]+-- arbor tree-get | enriched["arbor"].oneOf[1]+-- arbor tree-list | enriched["arbor"].oneOf[3]+-- cone list | enriched["cone"].oneOf[1]+--+-- The mapping is guaranteed by the order in ActivationInfo.methods+-- matching the order in the enriched schema's oneOf array.
+ plexus-synapse.cabal view
@@ -0,0 +1,196 @@+cabal-version: 3.0+name: plexus-synapse+version: 0.3.0.0+synopsis: Schema-driven CLI for Plexus RPC servers+license: MIT+author:+maintainer:+build-type: Simple++flag build-examples+ description: Build example programs (schema-discovery)+ default: False+ manual: True++library+ exposed-modules:+ Synapse.Schema.Types+ Synapse.Schema.Functor+ Synapse.Monad+ Synapse.Algebra.Navigate+ Synapse.Algebra.Render+ Synapse.Algebra.Walk+ Synapse.Algebra.Recursion+ Synapse.Transport+ Synapse.Cache+ Synapse.Renderer+ Synapse.IR.Types+ Synapse.IR.Builder+ Synapse.Bidir+ Synapse.CLI.Help+ Synapse.CLI.Parse+ Synapse.CLI.Support+ Synapse.CLI.Template+ Synapse.CLI.Transform+ Synapse.CLI.Similarity+ Synapse.Backend.Discovery+ Synapse.Self.Commands+ Synapse.Self.Template+ Synapse.Self.Pattern+ Synapse.Self.Examples+ build-depends:+ base >= 4.17 && < 5,+ plexus-protocol,+ aeson >= 2.0 && < 2.3,+ text >= 2.0 && < 2.2,+ bytestring >= 0.11 && < 0.13,+ websockets >= 0.13 && < 0.14,+ network >= 3.1 && < 3.3,+ async >= 2.2 && < 2.3,+ stm >= 2.5 && < 2.6,+ streaming >= 0.2 && < 0.3,+ mtl >= 2.3 && < 2.4,+ transformers >= 0.6 && < 0.7,+ containers >= 0.6 && < 0.8,+ unordered-containers >= 0.2 && < 0.3,+ hashable >= 1.4 && < 1.6,+ prettyprinter >= 1.7 && < 1.8,+ mustache >= 2.4 && < 2.5,+ directory >= 1.3 && < 1.4,+ filepath >= 1.4 && < 1.6,+ yaml >= 0.11 && < 0.12,+ vector >= 0.12 && < 0.14,+ scientific >= 0.3 && < 0.4,+ regex-tdfa >= 1.3 && < 1.4,+ time >= 1.12 && < 1.15,+ array >= 0.5 && < 0.6,+ process >= 1.6 && < 1.7+ hs-source-dirs: src+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ DeriveGeneric+ DeriveAnyClass+ DerivingStrategies+ GeneralizedNewtypeDeriving+ LambdaCase+ RecordWildCards++executable synapse+ main-is: Main.hs+ autogen-modules: Paths_plexus_synapse+ other-modules: Paths_plexus_synapse+ build-depends:+ base >= 4.17 && < 5,+ plexus-protocol,+ plexus-synapse,+ aeson >= 2.0 && < 2.3,+ text >= 2.0 && < 2.2,+ bytestring >= 0.11 && < 0.13,+ mtl >= 2.3 && < 2.4,+ containers >= 0.6 && < 0.8,+ directory >= 1.3 && < 1.4,+ filepath >= 1.4 && < 1.6,+ optparse-applicative >= 0.18 && < 0.19,+ prettyprinter >= 1.7 && < 1.8+ hs-source-dirs: app+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ RecordWildCards+ LambdaCase++executable schema-discovery+ main-is: SchemaDiscovery.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-protocol,+ plexus-synapse,+ aeson >= 2.0 && < 2.3,+ text >= 2.0 && < 2.2,+ streaming >= 0.2 && < 0.3+ hs-source-dirs: examples+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ if !flag(build-examples)+ buildable: False++test-suite cli-test+ type: exitcode-stdio-1.0+ main-is: CLISpec.hs+ build-depends:+ base >= 4.17 && < 5,+ text >= 2.0 && < 2.2,+ process >= 1.6 && < 1.7,+ hspec >= 2.10 && < 2.12+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ ghc-options: -threaded++test-suite ir-test+ type: exitcode-stdio-1.0+ main-is: IRSpec.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-synapse,+ text >= 2.0 && < 2.2,+ containers >= 0.6 && < 0.8,+ hspec >= 2.10 && < 2.12,+ aeson >= 2.2 && < 2.3,+ bytestring >= 0.11 && < 0.13+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ LambdaCase+ RecordWildCards+ ghc-options: -threaded++test-suite typeref-json+ type: exitcode-stdio-1.0+ main-is: TypeRefJson.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-synapse,+ text >= 2.0 && < 2.2,+ aeson >= 2.2 && < 2.3,+ aeson-pretty >= 0.8 && < 0.9,+ bytestring >= 0.11 && < 0.13+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ ghc-options: -threaded++test-suite parse-test+ type: exitcode-stdio-1.0+ main-is: ParseSpec.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-synapse,+ text >= 2.0 && < 2.2,+ aeson >= 2.2 && < 2.3,+ containers >= 0.6 && < 0.8,+ vector >= 0.12 && < 0.14,+ hspec >= 2.10 && < 2.12+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ ghc-options: -threaded++test-suite path-normalization-test+ type: exitcode-stdio-1.0+ main-is: PathNormalizationSpec.hs+ build-depends:+ base >= 4.17 && < 5,+ text >= 2.0 && < 2.2,+ hspec >= 2.10 && < 2.12+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ ghc-options: -threaded
@@ -0,0 +1,102 @@+-- | Navigation algebra (paramorphism)+--+-- = Why Paramorphism+--+-- Navigation requires inspecting child namespaces to match path segments.+-- A catamorphism only gives us the folded result — we lose the original structure.+-- A paramorphism gives us both: F(μF × A) → A+--+-- At each layer, we receive (original subtree, already-computed result) pairs.+-- We inspect the original to check namespaces, then recurse.+--+-- = Effectful Navigation+--+-- Since resolution requires network calls (fetch child schema), we can't use+-- pure 'para'. Instead, we implement navigation directly in SynapseM,+-- following the same pattern but with effects.+module Synapse.Algebra.Navigate+ ( -- * Navigation+ navigate+ , navigateFrom++ -- * Algebra Types+ , NavAlg+ , NavResult++ -- * Helpers+ , findChild+ , findMethod+ ) where++import Data.Text (Text)+import Data.List (find)++import Synapse.Schema.Types+import Synapse.Monad+import Synapse.Transport (fetchSchemaAt)+import Synapse.Cache (fetchCached)++-- | The navigation algebra type (conceptual)+--+-- In a pure setting with recursive schemas:+-- @+-- type NavAlg = PluginSchemaF (ChildSummary, NavResult) -> NavResult+-- @+--+-- With effectful resolution:+-- @+-- type NavAlg = PluginSchema -> Path -> Path -> SynapseM SchemaView+-- @+type NavAlg = PluginSchema -> Path -> Path -> SynapseM SchemaView++-- | Result of navigation: either a schema view or an error+type NavResult = SynapseM SchemaView++-- | Navigate to a target from root+-- Fetches root schema and navigates from there+-- Note: If path starts with root namespace (e.g., "plexus"), it's stripped+-- so that "synapse plexus cone" works the same as "synapse cone"+navigate :: Path -> SynapseM SchemaView+navigate target = do+ root <- fetchSchemaAt []+ -- Normalize path: strip leading root namespace if present+ let normalizedTarget = case target of+ (seg:rest) | seg == psNamespace root -> rest+ _ -> target+ withFreshVisited $ navigateFrom root [] normalizedTarget++-- | Navigate from a given schema+-- visited: path taken so far+-- target: remaining path to navigate+navigateFrom :: PluginSchema -> Path -> Path -> SynapseM SchemaView+navigateFrom schema visited = \case+ -- Empty target: we've arrived+ [] -> pure $ ViewPlugin schema visited++ -- Non-empty target: try to navigate+ (seg:rest) ->+ -- First check if seg is a child namespace+ case findChild seg schema of+ Just child -> do+ -- Check for cycle before descending+ checkCycle (csHash child) (visited ++ [seg])+ -- Fetch child schema (with caching)+ childSchema <- fetchCached (csHash child) (fetchSchemaAt (visited ++ [seg]))+ -- Recurse into child+ navigateFrom childSchema (visited ++ [seg]) rest++ Nothing ->+ -- Not a child — check if it's a method+ case findMethod seg schema of+ Just method+ | null rest -> pure $ ViewMethod method (visited ++ [seg])+ | otherwise -> throwNav $ MethodNotTerminal seg visited+ Nothing -> throwNav $ NotFound seg visited (Just schema)++-- | Find a child by namespace+findChild :: Text -> PluginSchema -> Maybe ChildSummary+findChild seg schema = find ((== seg) . csNamespace) (pluginChildren schema)++-- | Find a method by name+findMethod :: Text -> PluginSchema -> Maybe MethodSchema+findMethod seg schema = find ((== seg) . methodName) (psMethods schema)
+ src/Synapse/Algebra/Recursion.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Recursion schemes for schema trees+--+-- This module provides proper categorical recursion schemes:+--+-- = Anamorphism (unfold)+--+-- An anamorphism builds a recursive structure from a seed using a coalgebra:+--+-- @+-- coalgebra :: a -> f a -- one step of unfolding+-- ana :: Functor f => (a -> f a) -> a -> Fix f+-- ana coalg = Fix . fmap (ana coalg) . coalg+-- @+--+-- For effectful unfolding, we use 'anaM':+--+-- @+-- anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f)+-- @+--+-- = Catamorphism (fold)+--+-- A catamorphism collapses a recursive structure using an algebra:+--+-- @+-- algebra :: f a -> a -- one step of folding+-- cata :: Functor f => (f a -> a) -> Fix f -> a+-- cata alg = alg . fmap (cata alg) . unFix+-- @+--+-- = Hylomorphism (unfold then fold)+--+-- A hylomorphism composes an anamorphism with a catamorphism:+--+-- @+-- hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+-- hylo alg coalg = cata alg . ana coalg+-- = alg . fmap (hylo alg coalg) . coalg -- fused+-- @+--+-- The fused version never builds the intermediate structure!+module Synapse.Algebra.Recursion+ ( -- * Pure recursion schemes+ cata+ , ana+ , hylo+ , para+ , apo++ -- * Monadic recursion schemes+ , cataM+ , anaM+ , hyloM++ -- * Schema-specific operations+ , unfoldSchema+ , foldSchema+ , walkSchema++ -- * Re-exports+ , Fix(..)+ ) where++import Control.Monad (forM)+import Data.Text (Text)++import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..))+import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree)+import Synapse.Monad+import Synapse.Transport (fetchSchemaAt)++-- ============================================================================+-- Pure Recursion Schemes+-- ============================================================================++-- | Catamorphism: fold a recursive structure+--+-- @+-- cata alg = alg . fmap (cata alg) . unFix+-- @+cata :: Functor f => (f a -> a) -> Fix f -> a+cata alg = go+ where+ go (Fix fa) = alg (fmap go fa)++-- | Anamorphism: unfold to build a recursive structure+--+-- @+-- ana coalg = Fix . fmap (ana coalg) . coalg+-- @+ana :: Functor f => (a -> f a) -> a -> Fix f+ana coalg = go+ where+ go a = Fix (fmap go (coalg a))++-- | Hylomorphism: unfold then fold (fused - no intermediate structure)+--+-- @+-- hylo alg coalg = cata alg . ana coalg -- unfused+-- = alg . fmap (hylo alg coalg) . coalg -- fused+-- @+hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+hylo alg coalg = go+ where+ go a = alg (fmap go (coalg a))++-- | Paramorphism: fold with access to original substructures+--+-- Like cata but the algebra also receives the original subtree+para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a+para alg = go+ where+ go (Fix fa) = alg (fmap (\x -> (x, go x)) fa)++-- | Apomorphism: unfold with early termination+--+-- Like ana but can short-circuit by returning Right with final value+apo :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f+apo coalg = go+ where+ go a = Fix (fmap (either id go) (coalg a))++-- ============================================================================+-- Monadic Recursion Schemes+-- ============================================================================++-- | Monadic catamorphism+--+-- Fold with effects at each step+cataM :: (Monad m, Traversable f) => (f a -> m a) -> Fix f -> m a+cataM alg = go+ where+ go (Fix fa) = do+ fa' <- traverse go fa -- recursively process children+ alg fa' -- apply algebra to results++-- | Monadic anamorphism+--+-- Unfold with effects at each step. This is what we need for+-- schema tree building since fetching is effectful.+anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f)+anaM coalg = go+ where+ go a = do+ fa <- coalg a -- one step of unfolding (effectful)+ fa' <- traverse go fa -- recursively unfold children+ pure (Fix fa')++-- | Monadic hylomorphism+--+-- Unfold then fold, both with effects. Fused version.+hyloM :: (Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b+hyloM alg coalg = go+ where+ go a = do+ fa <- coalg a -- unfold one step+ fb <- traverse go fa -- recursively process+ alg fb -- fold one step++-- ============================================================================+-- Schema-Specific Operations+-- ============================================================================++-- | Coalgebra for unfolding schema trees+--+-- Given a path, fetch the schema and produce one layer of SchemaF+-- with child paths in the recursive positions.+schemaCoalgebra :: Path -> SynapseM (SchemaF Path)+schemaCoalgebra path = do+ schema <- fetchSchemaAt path+ let childPaths = case psChildren schema of+ Nothing -> []+ Just children -> [path ++ [csNamespace c] | c <- children]+ pure $ PluginF schema path childPaths++-- | Unfold a complete schema tree from a path+--+-- This is anaM applied to our schema coalgebra.+-- Builds the full tree structure by fetching all schemas.+unfoldSchema :: Path -> SynapseM SchemaTree+unfoldSchema = anaM schemaCoalgebra++-- | Fold a schema tree with an algebra+--+-- Pure fold - use this when you've already built the tree.+foldSchema :: (SchemaF a -> a) -> SchemaTree -> a+foldSchema = cata++-- | Walk the schema tree with a monadic hylomorphism+--+-- This is the main operation: unfold from a path, fold with an algebra.+-- Fused, so doesn't build intermediate tree in memory.+walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a+walkSchema alg = hyloM alg schemaCoalgebra
+ src/Synapse/Algebra/Render.hs view
@@ -0,0 +1,207 @@+-- | Render algebra for PluginSchema+module Synapse.Algebra.Render+ ( -- * Rendering Functions+ renderSchema+ , renderSchemaWith+ , renderMethod+ , renderMethodFull+ , renderChild+ , renderParams++ -- * Configuration+ , RenderStyle(..)+ , defaultStyle+ , compactStyle+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Aeson (Value(..))+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import Data.List (intersperse, sortOn)+import Prettyprinter+import Prettyprinter.Render.Text (renderStrict)++import Synapse.Schema.Types++-- | Rendering style configuration+data RenderStyle = RenderStyle+ { rsIndent :: !Int -- ^ Spaces per indent level+ , rsShowHash :: !Bool -- ^ Show plugin/method hashes+ , rsShowTypes :: !Bool -- ^ Show parameter types+ , rsCompact :: !Bool -- ^ Compact single-line format+ }+ deriving stock (Show, Eq)++-- | Default style: readable multi-line output+defaultStyle :: RenderStyle+defaultStyle = RenderStyle+ { rsIndent = 2+ , rsShowHash = False+ , rsShowTypes = True+ , rsCompact = False+ }++-- | Compact style: single-line descriptions+compactStyle :: RenderStyle+compactStyle = defaultStyle { rsCompact = True }++-- | Render a PluginSchema+renderSchema :: PluginSchema -> Text+renderSchema = renderSchemaWith defaultStyle++-- | Render with custom style+renderSchemaWith :: RenderStyle -> PluginSchema -> Text+renderSchemaWith _style PluginSchema{..}+ | null psMethods && maybe True null psChildren = headerText+ | otherwise = renderStrict $ layoutPretty layoutOpts doc+ where+ layoutOpts = LayoutOptions (AvailablePerLine 80 1.0)++ headerText = psNamespace <> " v" <> psVersion <> "\n" <> psDescription <> "\n"++ doc :: Doc ann+ doc = vsep+ [ pretty psNamespace <+> pretty ("v" <> psVersion)+ , emptyDoc+ , indent 2 $ align $ fillSep $ map pretty $ T.words psDescription+ , emptyDoc+ , childrenDoc+ , methodsDoc+ ]++ childrenDoc = case psChildren of+ Nothing -> emptyDoc+ Just [] -> emptyDoc+ Just children -> vsep+ [ pretty ("activations" :: Text)+ , emptyDoc+ , indent 2 $ vsep $ map renderChildDoc (sortOn csNamespace children)+ , emptyDoc+ ]++ methodsDoc+ | null psMethods = emptyDoc+ | otherwise = vsep+ [ pretty ("methods" :: Text)+ , emptyDoc+ , indent 2 $ vsep $ intersperse emptyDoc $ map renderMethodDoc (sortOn methodName psMethods)+ ]++ renderChildDoc child = fillBreak 12 (pretty $ csNamespace child)+ <+> align (fillSep $ map pretty $ T.words $ csDescription child)++ renderMethodDoc method = vsep $+ [ fillBreak 12 (pretty $ methodName method)+ <+> align (fillSep $ map pretty $ T.words $ methodDescription method)+ ] ++ paramsDocs (methodParams method)++ paramsDocs Nothing = []+ paramsDocs (Just (Object o)) = case KM.lookup "properties" o of+ Just (Object props) ->+ let reqList = case KM.lookup "required" o of+ Just (Array arr) -> [t | String t <- foldr (:) [] arr]+ _ -> []+ propList = KM.toList props+ sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList+ in [indent 12 $ vsep $ map (renderParamDoc reqList) sorted]+ _ -> []+ paramsDocs _ = []++ renderParamDoc :: [Text] -> (K.Key, Value) -> Doc ann+ renderParamDoc required (name, propSchema) =+ let nameText = K.toText name+ isReq = nameText `elem` required+ (typ, desc) = extractTypeDesc propSchema+ flag = "--" <> T.replace "_" "-" nameText+ typStr = " <" <> typ <> ">" <> if isReq then "" else "?"+ descWords = if T.null desc then [] else map pretty (T.words desc)+ in fillBreak 20 (pretty flag <> pretty typStr)+ <+> align (fillSep descWords)++-- | Render a method (short form)+renderMethod :: MethodSchema -> Text+renderMethod = renderMethodWith defaultStyle++-- | Render a method with style+renderMethodWith :: RenderStyle -> MethodSchema -> Text+renderMethodWith RenderStyle{..} m =+ " " <> padRight 16 (methodName m) <> methodDescription m+ <> if rsShowTypes then renderParams (methodParams m) else ""++-- | Render a method (full form with all params)+renderMethodFull :: MethodSchema -> Text+renderMethodFull m = T.unlines $+ [ methodName m <> " - " <> methodDescription m+ , ""+ ] <> paramLines+ where+ paramLines = case methodParams m of+ Nothing -> [" (no parameters)"]+ Just schema -> renderParamsFull schema++-- | Render a child summary+renderChild :: ChildSummary -> Text+renderChild child =+ " " <> padRight 16 (csNamespace child) <> csDescription child++-- | Render parameters inline+renderParams :: Maybe Value -> Text+renderParams Nothing = ""+renderParams (Just (Object o)) = case KM.lookup "properties" o of+ Just (Object props) ->+ let reqList = case KM.lookup "required" o of+ Just (Array arr) -> [t | String t <- foldr (:) [] arr]+ _ -> []+ propList = KM.toList props+ sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList+ rendered = map (renderParam reqList) sorted+ in if null rendered then "" else "\n" <> T.intercalate "\n" rendered+ _ -> ""+renderParams _ = ""++-- | Render a single parameter+renderParam :: [Text] -> (K.Key, Value) -> Text+renderParam required (name, propSchema) =+ let nameText = K.toText name+ isReq = nameText `elem` required+ flagName = T.replace "_" "-" nameText+ (typ, desc) = extractTypeDesc propSchema+ reqMarker = if isReq then "" else "?"+ in " --" <> flagName <> " <" <> typ <> ">" <> reqMarker <> " " <> desc++-- | Render parameters in full (for method help)+renderParamsFull :: Value -> [Text]+renderParamsFull (Object o) = case KM.lookup "properties" o of+ Just (Object props) ->+ let reqList = case KM.lookup "required" o of+ Just (Array arr) -> [t | String t <- foldr (:) [] arr]+ _ -> []+ propList = KM.toList props+ sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList+ in map (renderParamFull reqList) sorted+ _ -> []+renderParamsFull _ = []++renderParamFull :: [Text] -> (K.Key, Value) -> Text+renderParamFull required (name, propSchema) =+ let nameText = K.toText name+ isReq = nameText `elem` required+ (typ, desc) = extractTypeDesc propSchema+ reqText = if isReq then " (required)" else " (optional)"+ in " --" <> nameText <> " <" <> typ <> ">" <> reqText <> "\n " <> desc++-- | Extract type and description from property schema+extractTypeDesc :: Value -> (Text, Text)+extractTypeDesc (Object po) =+ ( case KM.lookup "type" po of { Just (String t) -> t; _ -> "any" }+ , case KM.lookup "description" po of { Just (String d) -> d; _ -> "" }+ )+extractTypeDesc _ = ("any", "")++-- | Pad text to a minimum width+padRight :: Int -> Text -> Text+padRight n t+ | T.length t >= n = t <> " "+ | otherwise = t <> T.replicate (n - T.length t) " "
+ src/Synapse/Algebra/Walk.hs view
@@ -0,0 +1,149 @@+-- | Schema tree walking via recursion schemes+--+-- This module provides schema traversal using proper categorical machinery:+--+-- = Anamorphism (Unfold)+--+-- The schema tree is built via anamorphism - we have a coalgebra that+-- produces one layer of 'SchemaF' from a path seed:+--+-- @+-- coalgebra :: Path -> SynapseM (SchemaF Path)+-- @+--+-- Iterating this coalgebra builds the full tree:+--+-- @+-- unfoldSchema :: Path -> SynapseM SchemaTree+-- unfoldSchema = anaM coalgebra+-- @+--+-- = Catamorphism (Fold)+--+-- To process the tree, we use algebras. A method-collecting algebra:+--+-- @+-- methodAlgebra :: SchemaF [MethodInfo] -> [MethodInfo]+-- methodAlgebra (PluginF schema path children) =+-- localMethods ++ concat children+-- methodAlgebra (MethodF method ns path) =+-- [MethodInfo method path ns]+-- @+--+-- = Hylomorphism (Unfold then Fold)+--+-- Most operations combine unfold and fold. Using 'hyloM' we get fusion:+--+-- @+-- walkMethods :: Path -> SynapseM [MethodInfo]+-- walkMethods = hyloM methodAlgebra schemaCoalgebra+-- @+--+-- The fused version never materializes the intermediate tree!+module Synapse.Algebra.Walk+ ( -- * Recursion Schemes+ walkMethods+ , walkSchema+ , foldMethods++ -- * Building Trees+ , unfoldSchema+ , foldSchema++ -- * Types+ , MethodInfo(..)+ , SchemaF(..)+ , SchemaTree++ -- * Re-exports for algebras+ , Fix(..)+ ) where++import Data.Text (Text)++import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..))+import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree)+import Synapse.Monad+import Synapse.Algebra.Recursion (hyloM, unfoldSchema, foldSchema)+import Synapse.Transport (fetchSchemaAt)++-- | Information about a method in context+data MethodInfo = MethodInfo+ { miMethod :: MethodSchema -- ^ The method schema+ , miPath :: Path -- ^ Full path to this method+ , miNamespace :: Text -- ^ Parent namespace+ }+ deriving stock (Show, Eq)++-- ============================================================================+-- Algebras+-- ============================================================================++-- | Algebra for collecting methods+--+-- This is a proper F-algebra: SchemaF [MethodInfo] -> [MethodInfo]+-- It shows how to combine child results with local data.+methodAlgebra :: SchemaF [MethodInfo] -> [MethodInfo]+methodAlgebra (PluginF schema path childResults) =+ -- Local methods from this plugin+ let localMethods =+ [ MethodInfo m (path ++ [methodName m]) (psNamespace schema)+ | m <- psMethods schema+ ]+ -- Combine with results from children (already processed)+ in localMethods ++ concat childResults+methodAlgebra (MethodF method ns path) =+ -- Method nodes are leaves - just wrap in list+ [MethodInfo method path ns]++-- | Monadic algebra for collecting methods (for hyloM)+methodAlgebraM :: SchemaF [MethodInfo] -> SynapseM [MethodInfo]+methodAlgebraM = pure . methodAlgebra++-- ============================================================================+-- Coalgebras+-- ============================================================================++-- | Coalgebra for unfolding schema trees+--+-- This is a proper F-coalgebra: Path -> SynapseM (SchemaF Path)+-- It shows how to produce one layer from a seed.+schemaCoalgebra :: Path -> SynapseM (SchemaF Path)+schemaCoalgebra path = do+ schema <- fetchSchemaAt path+ let childPaths = case psChildren schema of+ Nothing -> []+ Just children -> [path ++ [csNamespace c] | c <- children]+ pure $ PluginF schema path childPaths++-- ============================================================================+-- Walking Operations+-- ============================================================================++-- | Walk the schema tree, collecting all methods+--+-- This is a hylomorphism: unfold from path, fold with method algebra.+-- Uses hyloM for the fused monadic version - no intermediate tree built!+--+-- @+-- walkMethods = hyloM methodAlgebraM schemaCoalgebra+-- @+walkMethods :: Path -> SynapseM [MethodInfo]+walkMethods = hyloM methodAlgebraM schemaCoalgebra++-- | Walk schema tree with a custom monadic algebra+--+-- General version - provide your own algebra.+walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a+walkSchema alg = hyloM alg schemaCoalgebra++-- | Fold over methods with pure transformations+--+-- Convenience wrapper: walk to collect methods, then map and combine.+foldMethods :: (MethodInfo -> a) -- ^ Transform each method+ -> ([a] -> b) -- ^ Combine results+ -> Path -- ^ Starting path+ -> SynapseM b+foldMethods f combine path = do+ methods <- walkMethods path+ pure $ combine $ map f methods
+ src/Synapse/Backend/Discovery.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Backend Discovery Abstraction+--+-- This module provides an abstraction layer for discovering Plexus RPC servers.+-- Currently implements a stub that returns hardcoded localhost:4444, but the+-- interface is designed to support future dynamic discovery via a directory+-- service.+--+-- = Future Vision+--+-- @+-- ┌─────────────┐ ┌──────────────────┐ ┌─────────────────┐+-- │ synapse │────▶│ Hub Directory │────▶│ Backend Hubs │+-- │ (CLI) │ │ (port 4444) │ │ (discovered) │+-- └─────────────┘ └──────────────────┘ └─────────────────┘+-- │+-- ▼+-- Returns list of:+-- - Hub name+-- - Connection info (host:port or https URL)+-- - Description+-- - Schema hash+-- @+--+-- = Usage+--+-- @+-- main :: IO ()+-- main = do+-- let discovery = stubDiscovery+-- backends <- discoverBackends discovery+-- -- Use backends to build CLI subcommands+-- @+module Synapse.Backend.Discovery+ ( -- * Backend Type+ Backend(..)++ -- * Discovery Interface+ , BackendDiscovery(..)++ -- * Implementations+ , stubDiscovery+ , registryDiscovery++ -- * Backend Discovery+ , getBackendAt++ -- * Health Checks+ , pingBackend+ , pingBackends+ ) where++import Data.Aeson (ToJSON, FromJSON, (.:), (.:?), withObject)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Control.Exception (catch, SomeException)+import Data.Either (isRight)+import Control.Concurrent.Async (mapConcurrently, race, async, wait)+import Control.Concurrent (threadDelay)+import Data.IORef (newIORef, writeIORef, readIORef)+import Control.Monad (void)+import Plexus.Client (SubstrateConfig(..))+import qualified Plexus.Transport as ST+import Plexus.Types (PlexusStreamItem(..), TransportError(..))++-- ============================================================================+-- Backend Type+-- ============================================================================++-- | A discovered backend hub+data Backend = Backend+ { backendName :: Text -- ^ e.g., "plexus"+ , backendDescription :: Text -- ^ Human-readable description+ , backendHost :: Text -- ^ Host to connect to+ , backendPort :: Int -- ^ Port+ , backendVersion :: Maybe Text -- ^ Version if known+ , backendReachable :: Maybe Bool -- ^ Whether backend is reachable (Nothing = not checked)+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- ============================================================================+-- Discovery Interface+-- ============================================================================++-- | Backend discovery interface+--+-- This is a record-of-functions pattern that allows swapping discovery+-- implementations without changing calling code. In the future, this could+-- become a typeclass if we need more sophisticated dispatch.+data BackendDiscovery = BackendDiscovery+ { discoverBackends :: IO [Backend]+ -- ^ Query for all available backends+ , getBackendInfo :: Text -> IO (Maybe Backend)+ -- ^ Get info for a specific backend by name+ }++-- ============================================================================+-- Stub Implementation+-- ============================================================================++-- | Stub discovery that returns empty list+--+-- Used as fallback when connection fails completely.+stubDiscovery :: BackendDiscovery+stubDiscovery = BackendDiscovery+ { discoverBackends = pure []+ , getBackendInfo = \_ -> pure Nothing+ }++-- ============================================================================+-- Registry Types+-- ============================================================================++-- | Registry backend info (from registry activation)+data RegistryBackendInfo = RegistryBackendInfo+ { rbiName :: Text+ , rbiHost :: Text+ , rbiPort :: Int+ , rbiProtocol :: Text+ , rbiDescription :: Maybe Text+ , rbiIsActive :: Bool+ }+ deriving (Show, Generic)++instance FromJSON RegistryBackendInfo where+ parseJSON = withObject "RegistryBackendInfo" $ \o -> do+ name <- o .: "name"+ host <- o .: "host"+ port <- o .: "port"+ protocol <- o .: "protocol"+ desc <- o .:? "description"+ active <- o .: "is_active"+ pure $ RegistryBackendInfo name host port protocol desc active++-- | Registry event wrapper+data RegistryEvent+ = BackendsEvent { backends :: [RegistryBackendInfo] }+ | BackendEvent { backend :: Maybe RegistryBackendInfo }+ deriving (Show, Generic)++instance FromJSON RegistryEvent where+ parseJSON = withObject "RegistryEvent" $ \o -> do+ eventType <- o .: "type" -- Rust uses #[serde(tag = "type")]+ case eventType :: Text of+ "backends" -> BackendsEvent <$> o .: "backends"+ "backend" -> BackendEvent <$> o .: "backend"+ _ -> fail $ "Unknown registry event type: " ++ T.unpack eventType++-- | Backend info response from _info endpoint+data BackendInfoResponse = BackendInfoResponse+ { birBackend :: Text+ }+ deriving (Show, Generic)++instance FromJSON BackendInfoResponse where+ parseJSON = withObject "BackendInfoResponse" $ \o -> do+ backendName <- o .: "backend"+ pure $ BackendInfoResponse backendName++-- ============================================================================+-- Registry-based Discovery+-- ============================================================================++-- | Query the registry activation for available backends+--+-- Connects to the registry service and queries for registered backends.+-- Falls back to stubDiscovery if registry is unavailable.+registryDiscovery :: Text -> Int -> BackendDiscovery+registryDiscovery registryHost registryPort = BackendDiscovery+ { discoverBackends = do+ -- First, discover the backend name using _info+ maybeBackendName <- discoverBackendName registryHost registryPort+ case maybeBackendName of+ Just discoveredName -> do+ -- Create a Backend entry for the discovered backend+ let discoveredBackend = Backend+ { backendName = discoveredName+ , backendDescription = "Backend discovered via _info"+ , backendHost = registryHost+ , backendPort = registryPort+ , backendVersion = Nothing+ , backendReachable = Nothing+ }++ -- Try to get additional backends from registry (if it exists)+ registryBackends <- queryRegistry registryHost registryPort discoveredName++ -- Only include discovered backend if not already in registry+ -- (prefer registry entry since it has more details)+ let matchesDiscovered b = backendName b == discoveredName+ && backendHost b == registryHost+ && backendPort b == registryPort+ isDuplicate = any matchesDiscovered registryBackends+ backends = if isDuplicate+ then registryBackends+ else [discoveredBackend] ++ registryBackends++ pure backends+ Nothing ->+ -- Connection failed completely+ discoverBackends stubDiscovery+ , getBackendInfo = queryBackend registryHost registryPort+ }++-- | Get the backend name at a given host/port via _info+-- Returns whatever backend is running there (e.g., "registry-hub", "plexus")+-- If that backend has a registry plugin, it can be used to discover other backends+getBackendAt :: Text -> Int -> IO (Maybe Text)+getBackendAt = discoverBackendName++-- | Discover the backend name by calling _info+discoverBackendName :: Text -> Int -> IO (Maybe Text)+discoverBackendName host port = do+ let cfg = SubstrateConfig+ { substrateHost = T.unpack host+ , substratePort = port+ , substratePath = "/"+ , substrateBackend = "" -- Not used for _info+ }+ result <- ST.rpcCallWith cfg "_info" Aeson.Null+ `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed")++ case result of+ Left _err -> pure Nothing+ Right items -> do+ -- Extract the backend name from subscription response+ case [Aeson.fromJSON content | StreamData _ _ _ content <- items] of+ (Aeson.Success (Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj ->+ pure (Just name)+ _ -> pure Nothing++-- | Query the registry for all backends+queryRegistry :: Text -> Int -> Text -> IO [Backend]+queryRegistry host port backendName = do+ -- Try registry query first+ queryRegistryImpl host port backendName `catch` \(_e :: SomeException) ->+ -- Return empty list on error - caller will handle fallback+ pure []++-- | Implementation of registry query+queryRegistryImpl :: Text -> Int -> Text -> IO [Backend]+queryRegistryImpl host port backendName = do+ let cfg = SubstrateConfig+ { substrateHost = T.unpack host+ , substratePort = port+ , substratePath = "/"+ , substrateBackend = backendName+ }+ -- Call registry.list through the backend+ result <- ST.invokeMethod cfg ["registry"] "list" (Aeson.object [])+ case result of+ Left _err -> pure []+ Right items -> do+ -- Extract content from stream items+ let contents = [c | StreamData _ _ _ c <- items]+ let events = [e | Aeson.Success e <- map Aeson.fromJSON contents]+ let backendInfos = concat [bs | BackendsEvent bs <- events]+ pure $ map convertBackend backendInfos++-- | Query for a specific backend by name+queryBackend :: Text -> Int -> Text -> IO (Maybe Backend)+queryBackend host port name = do+ -- First discover the backend name+ maybeBackendName <- discoverBackendName host port+ case maybeBackendName of+ Just discoveredName -> do+ -- Check if the requested name matches the discovered backend+ if name == discoveredName+ then pure $ Just Backend+ { backendName = discoveredName+ , backendDescription = "Backend discovered via _info"+ , backendHost = host+ , backendPort = port+ , backendVersion = Nothing+ , backendReachable = Nothing+ }+ else do+ -- Try to find it in the registry+ result <- catch+ (queryBackendImpl host port discoveredName name)+ (\(_e :: SomeException) -> pure Nothing)+ pure result+ Nothing -> getBackendInfo stubDiscovery name++-- | Implementation of backend get query+queryBackendImpl :: Text -> Int -> Text -> Text -> IO (Maybe Backend)+queryBackendImpl host port backendName name = do+ let cfg = SubstrateConfig+ { substrateHost = T.unpack host+ , substratePort = port+ , substratePath = "/"+ , substrateBackend = backendName+ }+ params = Aeson.object ["name" Aeson..= name]+ result <- ST.invokeMethod cfg ["registry"] "get" params+ case result of+ Left _err -> pure Nothing+ Right items -> do+ -- Extract content from stream items+ let contents = [c | StreamData _ _ _ c <- items]+ let events = [e | Aeson.Success e <- map Aeson.fromJSON contents]+ case [b | BackendEvent (Just b) <- events] of+ (info:_) -> pure $ Just (convertBackend info)+ [] -> pure Nothing++-- | Convert registry backend info to discovery backend+convertBackend :: RegistryBackendInfo -> Backend+convertBackend info = Backend+ { backendName = rbiName info+ , backendDescription = maybe "" id (rbiDescription info)+ , backendHost = rbiHost info+ , backendPort = rbiPort info+ , backendVersion = Nothing+ , backendReachable = Nothing -- Will be checked separately+ }++-- | Ping a backend to check if it's reachable (with 300ms timeout)+-- 300ms allows for WebSocket connection establishment overhead (~150-200ms)+-- plus actual RPC round-trip time+pingBackend :: Backend -> IO Backend+pingBackend backend = do+ let cfg = SubstrateConfig+ { substrateHost = T.unpack (backendHost backend)+ , substratePort = backendPort backend+ , substratePath = "/"+ , substrateBackend = "" -- _info has no namespace prefix+ }+ timeout = threadDelay 300000 >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend))+ rpcCall = ST.rpcCallWith cfg "_info" Aeson.Null+ `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed")++ -- Race the RPC call against a 300ms timeout+ result <- race timeout rpcCall+ let reachable = case result of+ Left _ -> False -- Timeout+ Right (Right _) -> True -- Success+ Right (Left _) -> False -- RPC error++ pure $ backend { backendReachable = Just reachable }++-- | Ping all backends in parallel+pingBackends :: [Backend] -> IO [Backend]+pingBackends backends = mapConcurrently pingBackend backends
+ src/Synapse/Bidir.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Bidirectional communication support for Synapse+--+-- This module handles bidirectional requests (confirm, prompt, select) from+-- the backend, supporting multiple modes for both human and agent users.+--+-- = Modes+--+-- - @interactive@: Uses TTY prompts (requires terminal)+-- - @json@: Outputs request as JSON to stdout, reads response from stdin+-- - @auto-cancel@: Automatically cancels all requests with a warning+-- - @defaults@: Uses default values from requests if available+-- - @--bidir-cmd CMD@: Spawns a subprocess per request (stdin=JSON, stdout=JSON)+-- - @--bidir-respond@: Prints request to stdout as JSON, returns Nothing so the+-- agent can respond via a separate @synapse \<backend\> respond@ invocation+--+-- = Protocol+--+-- When a @StreamRequest@ arrives, the handler:+-- 1. Processes it according to the current mode+-- 2. If a response is produced, sends it via @{backend}.respond@ RPC method+-- 3. If Nothing is returned (BidirRespond), the caller skips sending a response+module Synapse.Bidir+ ( -- * Types+ BidirMode(..)+ , parseBidirMode+ , defaultBidirMode++ -- * TTY Detection+ , isTTY+ , detectBidirMode++ -- * Request Handling+ , handleBidirRequest+ , BidirHandler+ ) where++import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as TIO+import System.IO (hClose, hFlush, hIsTerminalDevice, stderr, stdin, stdout)+import System.Process (createProcess, proc, std_in, std_out, StdStream(..), waitForProcess)+import System.Exit (ExitCode(..))++import Plexus.Types+ ( Request(..)+ , Response(..)+ , SelectOption(..)+ )++-- | Bidirectional communication mode+data BidirMode+ = BidirInteractive -- ^ Use TTY prompts (requires terminal)+ | BidirJson -- ^ Output request as JSON, read response from stdin+ | BidirAutoCancel -- ^ Automatically cancel all requests+ | BidirDefaults -- ^ Use default values from requests+ | BidirCmd Text -- ^ Spawn subprocess per request (stdin=JSON request, stdout=JSON response)+ | BidirRespond -- ^ Print request to stdout as JSON; agent responds via separate process call+ deriving (Show, Eq)++-- | Parse bidirectional mode from string+parseBidirMode :: Text -> Maybe BidirMode+parseBidirMode = \case+ "interactive" -> Just BidirInteractive+ "json" -> Just BidirJson+ "auto-cancel" -> Just BidirAutoCancel+ "defaults" -> Just BidirDefaults+ "respond" -> Just BidirRespond+ _ -> Nothing++-- | Default mode when running in TTY+defaultBidirMode :: BidirMode+defaultBidirMode = BidirInteractive++-- | Check if stdin is a terminal+isTTY :: IO Bool+isTTY = hIsTerminalDevice stdin++-- | Detect the appropriate bidirectional mode based on environment+-- Returns Interactive for TTY, AutoCancel for piped mode+detectBidirMode :: IO BidirMode+detectBidirMode = do+ tty <- isTTY+ pure $ if tty then BidirInteractive else BidirAutoCancel++-- | Handler type for bidirectional requests+-- Takes request ID, request data, and returns an optional response.+-- Nothing means no immediate response (e.g., BidirRespond mode; agent responds separately).+type BidirHandler = Text -> Request Value -> IO (Maybe (Response Value))++-- | Handle a bidirectional request according to the mode+handleBidirRequest :: BidirMode -> Text -> Request Value -> IO (Maybe (Response Value))+handleBidirRequest mode requestId req = case mode of+ BidirInteractive -> Just <$> handleInteractive requestId req+ BidirJson -> Just <$> handleJson requestId req+ BidirAutoCancel -> Just <$> handleAutoCancel requestId req+ BidirDefaults -> Just <$> handleDefaults requestId req+ BidirCmd cmd -> Just <$> handleCmd cmd requestId req+ BidirRespond -> handleRespond requestId req++-- | Interactive TTY handling+handleInteractive :: Text -> Request Value -> IO (Response Value)+handleInteractive _requestId req = case req of+ Confirm{..} -> do+ let defaultHint = case confirmDefault of+ Just True -> " [Y/n]"+ Just False -> " [y/N]"+ Nothing -> " [y/n]"+ TIO.putStr $ confirmMessage <> defaultHint <> ": "+ hFlush stdout+ input <- TIO.getLine+ let confirmed = case T.toLower (T.strip input) of+ "" -> case confirmDefault of+ Just d -> d+ Nothing -> False+ "y" -> True+ "yes" -> True+ _ -> False+ pure $ Confirmed confirmed++ Prompt{..} -> do+ let hint = case promptPlaceholder of+ Just ph -> " (" <> ph <> ")"+ Nothing -> ""+ TIO.putStr $ promptMessage <> hint <> ": "+ hFlush stdout+ input <- TIO.getLine+ let response = if T.null input+ then case promptDefault of+ Just d -> d+ Nothing -> String input+ else String input+ pure $ Value response++ Select{..} -> do+ TIO.putStrLn selectMessage+ mapM_ printOption (zip [1..] selectOptions)+ TIO.putStr "Select (enter number): "+ hFlush stdout+ input <- TIO.getLine+ case reads (T.unpack input) of+ [(n, "")] | n >= 1 && n <= length selectOptions ->+ let selected = optionValue (selectOptions !! (n - 1))+ in pure $ Selected [selected]+ _ -> pure Cancelled++ CustomRequest{} -> pure Cancelled+ where+ printOption :: (Int, SelectOption Value) -> IO ()+ printOption (idx, SelectOption{..}) = do+ let desc = case optionDescription of+ Just d -> " - " <> d+ Nothing -> ""+ TIO.putStrLn $ " " <> T.pack (show idx) <> ") " <> optionLabel <> desc++-- | JSON protocol handling for piped mode+-- Outputs request as a JSON line to stdout, reads a JSON response line from stdin+handleJson :: Text -> Request Value -> IO (Response Value)+handleJson requestId req = do+ let jsonReq = encode $ object+ [ "type" .= ("bidir_request" :: Text)+ , "request_id" .= requestId+ , "request" .= req+ ]+ LBS.putStrLn jsonReq+ hFlush stdout+ inputLine <- TIO.getLine+ case eitherDecode (LBS.fromStrict $ T.encodeUtf8 inputLine) of+ Left err -> do+ TIO.hPutStrLn stderr $ "[synapse] Failed to parse bidir response: " <> T.pack err+ pure Cancelled+ Right resp -> pure resp++-- | Auto-cancel mode: cancels all requests with a warning+handleAutoCancel :: Text -> Request Value -> IO (Response Value)+handleAutoCancel requestId req = do+ TIO.hPutStrLn stderr $ "[synapse] Auto-cancelling " <> requestTypeName req+ <> " request (id: " <> requestId <> ") - not in interactive mode"+ TIO.hPutStrLn stderr "[synapse] Use --bidir-mode to change: json, defaults, interactive"+ TIO.hPutStrLn stderr "[synapse] Or use --bidir-cmd CMD / --bidir-respond for agent mode"+ pure Cancelled++-- | Defaults mode: uses default values from requests if available+handleDefaults :: Text -> Request Value -> IO (Response Value)+handleDefaults requestId req = case req of+ Confirm{..} -> case confirmDefault of+ Just d -> do+ TIO.hPutStrLn stderr $ "[synapse] Using default for confirm (id: "+ <> requestId <> "): " <> if d then "yes" else "no"+ pure $ Confirmed d+ Nothing -> do+ TIO.hPutStrLn stderr $ "[synapse] No default for confirm (id: "+ <> requestId <> "), cancelling"+ pure Cancelled++ Prompt{..} -> case promptDefault of+ Just d -> do+ TIO.hPutStrLn stderr $ "[synapse] Using default for prompt (id: " <> requestId <> ")"+ pure $ Value d+ Nothing -> do+ TIO.hPutStrLn stderr $ "[synapse] No default for prompt (id: "+ <> requestId <> "), cancelling"+ pure Cancelled++ Select{..} -> do+ TIO.hPutStrLn stderr $ "[synapse] No default for select (id: "+ <> requestId <> "), cancelling"+ pure Cancelled++ CustomRequest{} -> pure Cancelled++-- | Command mode: spawn a subprocess per request+-- The subprocess receives a JSON object on stdin:+-- {"request_id": "...", "request": {...}}+-- And must write a JSON Response object to stdout:+-- {"type": "confirmed", "value": true}+handleCmd :: Text -> Text -> Request Value -> IO (Response Value)+handleCmd cmd requestId req = do+ let reqJson = encode $ object+ [ "request_id" .= requestId+ , "request" .= req+ ]+ (Just hIn, Just hOut, _, ph) <- createProcess (proc "sh" ["-c", T.unpack cmd])+ { std_in = CreatePipe+ , std_out = CreatePipe+ }+ LBS.hPutStr hIn reqJson+ hClose hIn+ outputBytes <- LBS.hGetContents hOut+ exitCode <- waitForProcess ph+ case exitCode of+ ExitFailure code -> do+ TIO.hPutStrLn stderr $ "[synapse] --bidir-cmd subprocess exited with code "+ <> T.pack (show code) <> " (id: " <> requestId <> ")"+ pure Cancelled+ ExitSuccess -> case eitherDecode outputBytes of+ Left err -> do+ TIO.hPutStrLn stderr $ "[synapse] Failed to parse --bidir-cmd response: " <> T.pack err+ pure Cancelled+ Right resp -> pure resp++-- | Respond mode: print request to stdout as JSON, return Nothing+-- The caller (invokeStreamingWithBidir) will skip sending a response.+-- The agent is expected to call: synapse <backend> respond --request-id <id> --response <json>+handleRespond :: Text -> Request Value -> IO (Maybe (Response Value))+handleRespond requestId req = do+ let jsonReq = encode $ object+ [ "type" .= ("bidir_request" :: Text)+ , "request_id" .= requestId+ , "request" .= req+ ]+ LBS.putStrLn jsonReq+ hFlush stdout+ pure Nothing++-- | Get a human-readable name for the request type+requestTypeName :: Request t -> Text+requestTypeName = \case+ Confirm{} -> "confirm"+ Prompt{} -> "prompt"+ Select{} -> "select"+ CustomRequest{} -> "custom"
+ src/Synapse/CLI/Help.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | IR-based help rendering for CLI+--+-- Renders method and parameter help directly from the IR, providing+-- structured type information including discriminated union expansion.+--+-- = Design+--+-- Instead of parsing JSON Schema ad-hoc, we use the pre-built IR:+--+-- @+-- IR (types, methods)+-- |+-- +-> renderMethodHelp -> full method documentation+-- +-> renderParamHelp -> parameter with type expansion+-- +-> expandType -> discriminated union variants+-- +-> renderTypeRef -> type signature string+-- @+--+-- = Example Output+--+-- @+-- cone.chat - Chat with a cone+--+-- Parameters:+-- --identifier <ConeIdentifier> (required)+-- Cone name or UUID+-- Either:+-- --identifier.type by_name --identifier.name <string>+-- --identifier.type by_id --identifier.id <uuid>+--+-- --prompt <string> (required)+-- User message / prompt to send+--+-- --ephemeral <boolean> (optional)+-- If true, doesn't advance head+-- @+module Synapse.CLI.Help+ ( -- * Method Help+ renderMethodHelp+ , renderMethodHelpWith++ -- * Parameter Help+ , renderParamHelp+ , renderParamHelpWith++ -- * Type Rendering+ , renderTypeRef+ , expandType++ -- * Configuration+ , HelpStyle(..)+ , defaultHelpStyle+ ) where++import Data.List (intersperse)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, maybeToList)+import Data.Text (Text)+import qualified Data.Text as T++import Synapse.IR.Types++-- ============================================================================+-- Configuration+-- ============================================================================++-- | Style configuration for help rendering+data HelpStyle = HelpStyle+ { hsIndent :: !Int -- ^ Spaces per indent level+ , hsParamWidth :: !Int -- ^ Width for parameter column+ , hsShowFormats :: !Bool -- ^ Show format hints (uuid, int64, etc.)+ , hsExpandEnums :: !Bool -- ^ Expand enum variants inline+ }+ deriving stock (Show, Eq)++-- | Default help style+defaultHelpStyle :: HelpStyle+defaultHelpStyle = HelpStyle+ { hsIndent = 2+ , hsParamWidth = 30+ , hsShowFormats = True+ , hsExpandEnums = True+ }++-- ============================================================================+-- Method Help+-- ============================================================================++-- | Render complete help for a method+renderMethodHelp :: IR -> MethodDef -> Text+renderMethodHelp = renderMethodHelpWith defaultHelpStyle++-- | Render method help with custom style+renderMethodHelpWith :: HelpStyle -> IR -> MethodDef -> Text+renderMethodHelpWith style ir method = T.unlines $+ [ header+ , ""+ ] ++ descSection ++ paramSection+ where+ header = mdFullPath method <> streamingIndicator++ streamingIndicator+ | mdStreaming method = " [streaming]"+ | otherwise = ""++ descSection = case mdDescription method of+ Just desc -> [desc, ""]+ Nothing -> []++ paramSection+ | null (mdParams method) = ["(no parameters)"]+ | otherwise =+ ["Parameters:"] +++ concatMap (renderParamBlock style ir) (mdParams method)++-- | Render a parameter as a block (may be multi-line for complex types)+renderParamBlock :: HelpStyle -> IR -> ParamDef -> [Text]+renderParamBlock style ir param =+ let indent' = T.replicate (hsIndent style) " "+ indent2 = T.replicate (hsIndent style * 2) " "++ -- Parameter header line+ flagName = "--" <> T.replace "_" "-" (pdName param) -- Display as kebab-case+ typeStr = renderTypeRef ir (pdType param)+ reqText = if pdRequired param then "(required)" else "(optional)"+ headerLine = indent' <> flagName <> " <" <> typeStr <> "> " <> reqText++ -- Description line+ descLines = case pdDescription param of+ Just desc -> [indent2 <> desc]+ Nothing -> []++ -- Type expansion (for enums/unions)+ expansionLines = if hsExpandEnums style+ then map (indent2 <>) (expandType ir (pdName param) (pdType param))+ else []++ in [""] ++ [headerLine] ++ descLines ++ expansionLines++-- ============================================================================+-- Parameter Help+-- ============================================================================++-- | Render help for a single parameter+renderParamHelp :: IR -> ParamDef -> [Text]+renderParamHelp = renderParamHelpWith defaultHelpStyle++-- | Render parameter help with custom style+renderParamHelpWith :: HelpStyle -> IR -> ParamDef -> [Text]+renderParamHelpWith style ir param = renderParamBlock style ir param++-- ============================================================================+-- Type Rendering+-- ============================================================================++-- | Render a type reference as a type signature string+--+-- Examples:+-- RefPrimitive "string" Nothing -> "string"+-- RefPrimitive "string" (Just "uuid") -> "uuid"+-- RefArray (RefPrimitive "string" Nothing) -> "string[]"+-- RefOptional (RefNamed "Foo") -> "Foo?"+-- RefNamed "ConeIdentifier" -> "ConeIdentifier"+renderTypeRef :: IR -> TypeRef -> Text+renderTypeRef ir = \case+ RefNamed qn -> qualifiedNameFull qn++ RefPrimitive typ mFormat+ | Just fmt <- mFormat -> fmt -- Use format as type (uuid, int64, etc.)+ | otherwise -> typ++ RefArray inner -> renderTypeRef ir inner <> "[]"++ RefOptional inner -> renderTypeRef ir inner <> "?"++ RefAny -> "any"++ RefUnknown -> "unknown"++-- | Expand a type into CLI flag examples+--+-- For discriminated unions, shows each variant with its fields.+-- Returns empty list for simple types.+--+-- Example for ConeIdentifier:+-- @+-- ["Either:"+-- ," --identifier.type by_name --identifier.name <string>"+-- ," --identifier.type by_id --identifier.id <uuid>"+-- ]+-- @+expandType :: IR -> Text -> TypeRef -> [Text]+expandType ir prefix = \case+ RefNamed qn -> expandNamedType ir prefix (qualifiedNameFull qn)+ RefOptional inner -> expandType ir prefix inner+ _ -> [] -- Primitives and arrays don't expand++-- | Expand a named type by looking it up in the IR+expandNamedType :: IR -> Text -> Text -> [Text]+expandNamedType ir prefix typeName =+ case Map.lookup typeName (irTypes ir) of+ Nothing -> [] -- Type not found, no expansion+ Just typeDef -> expandTypeDef ir prefix typeDef++-- | Expand a type definition+expandTypeDef :: IR -> Text -> TypeDef -> [Text]+expandTypeDef ir prefix TypeDef{..} = case tdKind of+ -- Discriminated union: show each variant+ KindEnum discriminator variants+ | length variants > 1 -> expandEnum ir prefix discriminator variants+ | otherwise -> []++ -- Struct: could expand fields, but typically too verbose+ KindStruct _fields -> []++ -- Alias: expand the target+ KindAlias target -> expandType ir prefix target++ -- Primitives don't expand+ KindPrimitive _ _ -> []++ -- String enums don't expand (just string literals)+ KindStringEnum _ -> []++-- | Expand an enum (discriminated union) into variant examples+expandEnum :: IR -> Text -> Text -> [VariantDef] -> [Text]+expandEnum ir prefix discriminator variants =+ ["Either:"] ++ map ((" " <>) . renderVariantExample ir prefix discriminator) variants++-- | Render a single variant as a CLI example+--+-- Example: "--identifier.type by_name --identifier.name <string>"+renderVariantExample :: IR -> Text -> Text -> VariantDef -> Text+renderVariantExample ir prefix discriminator VariantDef{..} =+ let prefix' = T.replace "_" "-" prefix -- Display as kebab-case+ disc' = T.replace "_" "-" discriminator -- Display as kebab-case+ discFlag = "--" <> prefix' <> "." <> disc' <> " " <> vdName+ fieldFlags = map (renderFieldFlag ir prefix') vdFields+ in T.intercalate " " (discFlag : fieldFlags)++-- | Render a field as a CLI flag+--+-- Example: "--identifier.name <string>"+renderFieldFlag :: IR -> Text -> FieldDef -> Text+renderFieldFlag ir prefix FieldDef{..} =+ let name' = T.replace "_" "-" fdName -- Display as kebab-case+ in "--" <> prefix <> "." <> name' <> " <" <> renderTypeRef ir fdType <> ">"++-- ============================================================================+-- String Enum Helpers+-- ============================================================================++-- | Check if a type is a string enum and get its values+getStringEnumValues :: IR -> TypeRef -> Maybe [Text]+getStringEnumValues ir (RefNamed qn) =+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just TypeDef{tdKind = KindEnum "value" variants} ->+ Just $ map vdName variants+ _ -> Nothing+getStringEnumValues _ _ = Nothing++-- | Render string enum values inline+-- Example: "One of: pending, in_progress, completed"+renderStringEnumHint :: [Text] -> Text+renderStringEnumHint values = "One of: " <> T.intercalate ", " values
+ src/Synapse/CLI/Parse.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | IR-driven parameter parsing for CLI+--+-- Transforms flat --key value pairs into properly nested JSON using IR type information.+--+-- = Problem+--+-- CLI flags are flat: @--identifier.type by_name --identifier.name foo@+-- Server expects nested: @{"identifier": {"type": "by_name", "name": "foo"}}@+--+-- = Solution+--+-- Use IR type definitions to understand the structure:+--+-- @+-- IR lookup: identifier -> RefNamed "ConeIdentifier"+-- IR lookup: ConeIdentifier -> KindEnum "type" [VariantDef "by_name" [...], ...]+-- Result: {"identifier": {"type": "by_name", "name": "foo"}}+-- @+--+-- = Design+--+-- Dotted keys are grouped by their first segment:+--+-- @+-- [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")]+-- -> Map.fromList [("identifier", [("type", "by_name"), ("name", "foo")]),+-- ("prompt", [("", "hi")])]+-- @+--+-- Each group is then built according to its parameter's TypeRef.+--+-- = Arrays+--+-- Repeated flags are collected into arrays:+--+-- @+-- --tags backend --tags critical --tags urgent+-- -> [("tags", [("", "backend"), ("", "critical"), ("", "urgent")])]+-- -> {"tags": ["backend", "critical", "urgent"]}+-- @+module Synapse.CLI.Parse+ ( -- * Parsing+ parseParams+ , ParseError(..)++ -- * Helpers (exposed for testing)+ , groupByPrefix+ , buildParamValue+ ) where++import Data.Aeson (Value(..), object)+import qualified Data.Aeson.Key as K+import Data.List (find)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Scientific (Scientific)+import qualified Data.Vector as V+import Text.Read (readMaybe)++import Synapse.IR.Types+import Synapse.CLI.Similarity (suggestCorrections)++-- ============================================================================+-- Error Types+-- ============================================================================++-- | Errors that can occur during parameter parsing+data ParseError+ = UnknownParam Text [Text]+ -- ^ Flag doesn't match any known parameter (param name, suggestions)+ | MissingRequired Text+ -- ^ Required parameter was not provided+ | InvalidValue Text Text+ -- ^ Invalid value for parameter (param name, reason)+ | AmbiguousVariant Text [Text]+ -- ^ Multiple variants could match (discriminator, variant names)+ | MissingDiscriminator Text Text+ -- ^ Enum type missing discriminator value (param name, discriminator field)+ | UnknownVariant Text Text [Text] [Text]+ -- ^ Unknown variant name (param name, provided value, valid variants, suggestions)+ | TypeNotFound Text+ -- ^ Referenced type not found in IR+ deriving (Show, Eq)++-- ============================================================================+-- Main Parsing Function+-- ============================================================================++-- | Parse flat key-value pairs into nested JSON using IR structure+--+-- Example:+-- @+-- parseParams ir method [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")]+-- = Right (object [("identifier", object [("type", "by_name"), ("name", "foo")]),+-- ("prompt", "hi")])+-- @+parseParams :: IR -> MethodDef -> [(Text, Text)] -> Either [ParseError] Value+parseParams ir method kvPairs = do+ -- Group keys by their top-level prefix+ let grouped = groupByPrefix kvPairs++ -- Build each parameter value+ let paramDefs = mdParams method+ let paramMap = Map.fromList [(pdName p, p) | p <- paramDefs]++ -- Process each group and collect results/errors+ let results = map (processGroup ir paramMap) (Map.toList grouped)++ -- Check for missing required params+ let providedParams = Map.keys grouped+ let missingRequired =+ [ MissingRequired (pdName p)+ | p <- paramDefs+ , pdRequired p+ , pdName p `notElem` providedParams+ , pdDefault p == Nothing -- Has no default value+ ]++ -- Collect all errors and results+ let (errors, values) = partitionResults results+ let allErrors = errors ++ missingRequired++ if null allErrors+ then Right $ object values+ else Left allErrors++-- | Process a single parameter group+processGroup :: IR -> Map Text ParamDef -> (Text, [(Text, Text)]) -> Either ParseError (K.Key, Value)+processGroup ir paramMap (paramName, subKeys) =+ case Map.lookup paramName paramMap of+ Nothing ->+ let validParams = Map.keys paramMap+ suggestions = suggestCorrections paramName validParams+ in Left $ UnknownParam paramName suggestions+ Just paramDef -> do+ val <- buildParamValue ir paramDef subKeys+ Right (K.fromText paramName, val)++-- | Partition results into errors and successes+partitionResults :: [Either ParseError (K.Key, Value)] -> ([ParseError], [(K.Key, Value)])+partitionResults = foldr partition ([], [])+ where+ partition (Left e) (errs, vals) = (e : errs, vals)+ partition (Right v) (errs, vals) = (errs, v : vals)++-- ============================================================================+-- Key Grouping+-- ============================================================================++-- | Group dotted keys by their first segment+--+-- Keys without dots get empty suffix:+-- @+-- [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")]+-- -> Map.fromList [("identifier", [("type", "by_name"), ("name", "foo")]),+-- ("prompt", [("", "hi")])]+-- @+groupByPrefix :: [(Text, Text)] -> Map Text [(Text, Text)]+groupByPrefix = foldr addPair Map.empty+ where+ addPair (key, val) acc =+ let (prefix, suffix) = splitKey key+ in Map.insertWith (++) prefix [(suffix, val)] acc++ splitKey key = case T.breakOn "." key of+ (pre, rest)+ | T.null rest -> (pre, "") -- No dot, empty suffix+ | otherwise -> (pre, T.drop 1 rest) -- Drop the dot++-- ============================================================================+-- Value Building+-- ============================================================================++-- | Build value for a single param using its TypeRef+buildParamValue :: IR -> ParamDef -> [(Text, Text)] -> Either ParseError Value+buildParamValue ir param kvs = case pdType param of+ RefPrimitive typ mFmt ->+ -- Simple value, expect single kv with empty suffix+ case lookup "" kvs of+ Just val -> Right $ inferTypedValue typ mFmt val+ Nothing -> Left $ InvalidValue (pdName param) "expected simple value"++ RefNamed qn ->+ let typeName = qualifiedNameFull qn+ in case Map.lookup typeName (irTypes ir) of+ Just typeDef -> buildFromTypeDef ir (pdName param) typeDef kvs+ Nothing ->+ -- Type not in IR, treat as simple value+ case lookup "" kvs of+ Just val -> Right $ String val+ Nothing -> Left $ TypeNotFound typeName++ RefOptional inner ->+ -- For optional, if we have values, parse the inner type+ if null kvs+ then Right Null+ else buildParamValue ir param{pdType = inner} kvs++ RefArray innerType ->+ -- Collect all repeated --key value entries+ let values = [val | ("", val) <- kvs]+ in if null values+ then Left $ InvalidValue (pdName param) "array requires at least one value"+ else Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values++ RefAny ->+ -- Dynamic type, try to parse as JSON or use as string+ case lookup "" kvs of+ Just val -> Right $ inferValue val+ Nothing -> Left $ InvalidValue (pdName param) "dynamic type needs value"++ RefUnknown ->+ -- Unknown type, best effort+ case lookup "" kvs of+ Just val -> Right $ inferValue val+ Nothing -> Left $ InvalidValue (pdName param) "unknown type needs value"++-- | Build value from a TypeDef+buildFromTypeDef :: IR -> Text -> TypeDef -> [(Text, Text)] -> Either ParseError Value+buildFromTypeDef ir paramName TypeDef{..} kvs = case tdKind of+ KindEnum discriminator variants ->+ -- Find which variant based on discriminator value+ case lookup discriminator kvs of+ Just variantName ->+ case find (\v -> vdName v == variantName) variants of+ Just variant -> buildVariant ir paramName discriminator variant kvs+ Nothing ->+ let validVariants = map vdName variants+ suggestions = suggestCorrections variantName validVariants+ in Left $ UnknownVariant paramName variantName validVariants suggestions+ Nothing -> Left $ MissingDiscriminator paramName discriminator++ KindStruct fields ->+ -- Build object from fields+ buildStruct ir paramName fields kvs++ KindAlias target ->+ -- Follow the alias+ buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing} kvs++ KindStringEnum allowedValues ->+ -- Expect single string value from allowed set+ case lookup "" kvs of+ Just val+ | val `elem` allowedValues -> Right $ String val+ | otherwise -> Left $ InvalidValue paramName $+ "must be one of: " <> T.intercalate ", " allowedValues+ Nothing -> Left $ InvalidValue paramName "expected enum value"++ KindPrimitive typ mFmt ->+ -- Expect single value+ case lookup "" kvs of+ Just val -> Right $ inferTypedValue typ mFmt val+ Nothing -> Left $ InvalidValue paramName "expected primitive value"++-- | Build a variant value (discriminator + variant fields)+buildVariant :: IR -> Text -> Text -> VariantDef -> [(Text, Text)] -> Either ParseError Value+buildVariant ir paramName discriminator VariantDef{..} kvs =+ let discPair = (K.fromText discriminator, String vdName)+ in case buildFieldPairs ir paramName vdFields kvs of+ Right fieldPairs -> Right $ object (discPair : fieldPairs)+ Left err -> Left err++-- | Build field pairs from a list of field definitions+buildFieldPairs :: IR -> Text -> [FieldDef] -> [(Text, Text)] -> Either ParseError [(K.Key, Value)]+buildFieldPairs ir paramName fields kvs = do+ let results = map (buildFieldPair ir paramName kvs) fields+ let (errors, pairs) = partitionResults results+ if null errors+ then Right pairs+ else Left (head errors) -- Return first error++-- | Build a single field pair+buildFieldPair :: IR -> Text -> [(Text, Text)] -> FieldDef -> Either ParseError (K.Key, Value)+buildFieldPair ir paramName kvs FieldDef{..} =+ case lookup fdName kvs of+ Just val -> Right (K.fromText fdName, buildTypedValue ir fdType val)+ Nothing+ | fdRequired -> Left $ MissingRequired (paramName <> "." <> fdName)+ | Just def <- fdDefault -> Right (K.fromText fdName, def)+ | otherwise -> Right (K.fromText fdName, Null)++-- | Build a struct value from fields+buildStruct :: IR -> Text -> [FieldDef] -> [(Text, Text)] -> Either ParseError Value+buildStruct ir paramName fields kvs = do+ pairs <- buildFieldPairs ir paramName fields kvs+ Right $ object pairs++-- | Build a typed value from a TypeRef+buildTypedValue :: IR -> TypeRef -> Text -> Value+buildTypedValue ir ref val = case ref of+ RefPrimitive typ mFmt -> inferTypedValue typ mFmt val+ RefNamed qn ->+ let typeName = qualifiedNameFull qn+ in case Map.lookup typeName (irTypes ir) of+ Just TypeDef{tdKind = KindPrimitive typ mFmt} -> inferTypedValue typ mFmt val+ _ -> String val+ RefOptional inner -> buildTypedValue ir inner val+ RefArray _ -> inferValue val -- Best effort for arrays+ RefAny -> inferValue val+ RefUnknown -> String val++-- ============================================================================+-- Value Inference+-- ============================================================================++-- | Infer JSON value from string using type hints+inferTypedValue :: Text -> Maybe Text -> Text -> Value+inferTypedValue typ mFmt val = case typ of+ "string" -> String val+ "integer" -> case readMaybe (T.unpack val) :: Maybe Integer of+ Just n -> Number (fromInteger n)+ Nothing -> String val+ "number" -> case readMaybe (T.unpack val) :: Maybe Double of+ Just n -> Number (realToFrac n)+ Nothing -> String val+ "boolean" -> case T.toLower val of+ "true" -> Bool True+ "false" -> Bool False+ "1" -> Bool True+ "0" -> Bool False+ _ -> String val+ _ -> String val -- Default to string for unknown types++-- | Infer JSON value from string without type hints+inferValue :: Text -> Value+inferValue t+ | t == "true" = Bool True+ | t == "false" = Bool False+ | t == "null" = Null+ | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n)+ | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n)+ | otherwise = String t++-- | Parse a string as JSON+parseJsonValue :: Text -> Either ParseError Value+parseJsonValue t =+ -- Try to parse as JSON, fall back to string+ Right $ inferValue t
+ src/Synapse/CLI/Similarity.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++-- | String similarity utilities for typo suggestions+--+-- Provides Levenshtein distance computation and correction suggestions+-- for CLI parameter names and variant values.+module Synapse.CLI.Similarity+ ( levenshteinDistance+ , suggestCorrections+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.List (sortOn)+import Data.Array++-- | Compute Levenshtein distance between two strings+--+-- Uses the Wagner-Fischer dynamic programming algorithm.+-- Time complexity: O(m*n) where m, n are string lengths.+--+-- Examples:+-- >>> levenshteinDistance "kitten" "sitting"+-- 3+-- >>> levenshteinDistance "message" "mesage"+-- 1+levenshteinDistance :: Text -> Text -> Int+levenshteinDistance s1 s2 = dp ! (m, n)+ where+ m = T.length s1+ n = T.length s2++ -- Dynamic programming array bounds: (0,0) to (m,n)+ bounds = ((0, 0), (m, n))++ -- DP table: dp!(i,j) = distance between first i chars of s1 and first j chars of s2+ dp = array bounds [(ij, dist ij) | ij <- range bounds]++ dist (0, j) = j -- s1 is empty, need j insertions+ dist (i, 0) = i -- s2 is empty, need i deletions+ dist (i, j) = minimum+ [ dp ! (i-1, j) + 1 -- deletion+ , dp ! (i, j-1) + 1 -- insertion+ , dp ! (i-1, j-1) + cost -- substitution+ ]+ where+ cost = if T.index s1 (i-1) == T.index s2 (j-1) then 0 else 1++-- | Find similar strings from a list of valid options+--+-- Returns up to 3 suggestions sorted by edit distance.+-- Only suggests strings within a reasonable edit distance threshold:+-- - Threshold = max(2, length/3)+-- - This filters out dissimilar strings+--+-- Examples:+-- >>> suggestCorrections "mesage" ["message", "massage", "passage"]+-- ["message"]+-- >>> suggestCorrections "cnt" ["count", "content", "constant"]+-- ["count", "content"]+suggestCorrections :: Text -> [Text] -> [Text]+suggestCorrections typo validOptions =+ let threshold = max 2 (T.length typo `div` 3)+ withDist = [(opt, levenshteinDistance typo opt) | opt <- validOptions]+ -- Filter: distance > 0 (not exact match) and <= threshold+ filtered = filter (\(_, d) -> d <= threshold && d > 0) withDist+ sorted = sortOn snd filtered+ in take 3 (map fst sorted)
+ src/Synapse/CLI/Support.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | CLI representability checks for IR types+--+-- Determines whether types from the IR can be represented as CLI flags.+-- This enables:+--+-- 1. Showing appropriate help (simple flags vs JSON input required)+-- 2. Tab completion for types that can be enumerated+-- 3. Validation before attempting CLI invocation+--+-- = Representability Rules+--+-- A type is CLI-representable if it can be expressed as --flag value pairs:+--+-- - Primitives: string, integer, number, boolean (always representable)+-- - UUID/formatted strings: representable as strings+-- - Optional T: representable if T is representable (flag is omittable)+-- - Arrays: representable via repeated flags (--key val1 --key val2 --key val3)+-- - Structs: representable if all required fields are representable+-- - Enums (discriminated): representable via --field.type variant --field.x ...+-- - String enums: representable (finite set of string values)+-- - Any/Unknown: NOT representable (need JSON input)+--+-- = Example+--+-- @+-- data SupportLevel+-- = FullSupport -- All params work as CLI flags+-- | PartialSupport -- Some params need JSON+-- | NoSupport -- Method requires JSON input+-- @+module Synapse.CLI.Support+ ( -- * Support Levels+ SupportLevel(..)+ , SupportReason(..)++ -- * Method Support+ , methodSupport+ , methodSupportDetails++ -- * Type Checks+ , canCLIRepresent+ , canCLIRepresentVariant+ , canCLIRepresentField++ -- * Utilities+ , unsupportedParams+ , requiredJsonParams+ ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T++import Synapse.IR.Types++-- ============================================================================+-- Support Levels+-- ============================================================================++-- | Level of CLI support for a method+data SupportLevel+ = FullSupport+ -- ^ All parameters can be expressed as CLI flags+ | PartialSupport [Text]+ -- ^ Some parameters require JSON input (listed by name)+ | NoSupport [Text]+ -- ^ Method requires JSON input for critical parameters+ deriving stock (Show, Eq)++-- | Reason why a type is not CLI representable+data SupportReason+ = ReasonArray+ -- ^ Arrays need JSON or special handling+ | ReasonNested+ -- ^ Deeply nested structure+ | ReasonAny+ -- ^ Type is dynamic (any)+ | ReasonUnknown+ -- ^ Type information missing+ | ReasonComplexUnion+ -- ^ Union with non-representable variants+ deriving stock (Show, Eq)++-- ============================================================================+-- Method Support+-- ============================================================================++-- | Check the CLI support level for a method+methodSupport :: IR -> MethodDef -> SupportLevel+methodSupport ir method =+ let unsupported = unsupportedParams ir method+ required = filter (isRequired method) unsupported+ in case (null unsupported, null required) of+ (True, _) -> FullSupport+ (False, True) -> PartialSupport unsupported+ (False, False) -> NoSupport required+ where+ isRequired m name = any (\p -> pdName p == name && pdRequired p) (mdParams m)++-- | Get detailed support information for a method+methodSupportDetails :: IR -> MethodDef -> [(Text, Either SupportReason ())]+methodSupportDetails ir method =+ [ (pdName p, checkParam p)+ | p <- mdParams method+ ]+ where+ checkParam p = case canCLIRepresentWithReason ir (pdType p) of+ Left reason -> Left reason+ Right () -> Right ()++-- ============================================================================+-- Type Representability+-- ============================================================================++-- | Check if a type can be represented as CLI flags+canCLIRepresent :: IR -> TypeRef -> Bool+canCLIRepresent ir typeRef = case canCLIRepresentWithReason ir typeRef of+ Right () -> True+ Left _ -> False++-- | Check representability with reason+canCLIRepresentWithReason :: IR -> TypeRef -> Either SupportReason ()+canCLIRepresentWithReason ir = \case+ -- Primitives are always representable+ RefPrimitive _ _ -> Right ()++ -- Optional types: representable if inner type is+ RefOptional inner -> canCLIRepresentWithReason ir inner++ -- Arrays are representable via repeated flags if the element type is representable+ RefArray innerType -> canCLIRepresentWithReason ir innerType++ -- Any/Unknown require JSON+ RefAny -> Left ReasonAny+ RefUnknown -> Left ReasonUnknown++ -- Named types: look up and check+ RefNamed qn -> canCLIRepresentNamed ir (qualifiedNameFull qn)++-- | Check if a named type is CLI representable+canCLIRepresentNamed :: IR -> Text -> Either SupportReason ()+canCLIRepresentNamed ir name =+ case Map.lookup name (irTypes ir) of+ Nothing -> Left ReasonUnknown+ Just typeDef -> canCLIRepresentTypeDef ir typeDef++-- | Check if a type definition is CLI representable+canCLIRepresentTypeDef :: IR -> TypeDef -> Either SupportReason ()+canCLIRepresentTypeDef ir TypeDef{..} = case tdKind of+ -- Primitives are representable+ KindPrimitive _ _ -> Right ()++ -- Alias: check the target+ KindAlias target -> canCLIRepresentWithReason ir target++ -- Structs: all fields must be representable+ KindStruct fields ->+ let checks = map (canCLIRepresentField ir) fields+ in case filter isLeftE checks of+ [] -> Right ()+ _ -> Left ReasonNested++ -- Enums: check based on discriminator type+ KindEnum discriminator variants+ -- String enums (discriminator is "value") are representable+ | discriminator == "value" -> Right ()+ -- Discriminated unions: all variants must be representable+ | otherwise ->+ let checks = map (canCLIRepresentVariantWithReason ir) variants+ in case filter isLeftE checks of+ [] -> Right ()+ _ -> Left ReasonComplexUnion++ -- String enums are representable (simple string literals)+ KindStringEnum _ -> Right ()++isLeftE :: Either a b -> Bool+isLeftE (Left _) = True+isLeftE (Right _) = False++-- | Check if a variant is CLI representable+canCLIRepresentVariant :: IR -> VariantDef -> Bool+canCLIRepresentVariant ir VariantDef{..} =+ all (canCLIRepresentField' ir) vdFields++-- | Check if a variant is representable (with reason)+canCLIRepresentVariantWithReason :: IR -> VariantDef -> Either SupportReason ()+canCLIRepresentVariantWithReason ir VariantDef{..} =+ let checks = map (canCLIRepresentField ir) vdFields+ in case filter isLeftE checks of+ [] -> Right ()+ _ -> Left ReasonNested++-- | Check if a field is CLI representable+canCLIRepresentField :: IR -> FieldDef -> Either SupportReason ()+canCLIRepresentField ir FieldDef{..} =+ canCLIRepresentWithReason ir fdType++-- | Check if a field is representable (Bool version)+canCLIRepresentField' :: IR -> FieldDef -> Bool+canCLIRepresentField' ir field = case canCLIRepresentField ir field of+ Right () -> True+ Left _ -> False++-- ============================================================================+-- Utilities+-- ============================================================================++-- | Get list of parameters that cannot be represented as CLI flags+unsupportedParams :: IR -> MethodDef -> [Text]+unsupportedParams ir method =+ [ pdName p+ | p <- mdParams method+ , not (canCLIRepresent ir (pdType p))+ ]++-- | Get parameters that require JSON input (non-representable + required)+requiredJsonParams :: IR -> MethodDef -> [Text]+requiredJsonParams ir method =+ [ pdName p+ | p <- mdParams method+ , pdRequired p+ , not (canCLIRepresent ir (pdType p))+ ]++-- ============================================================================+-- Depth Checking (for recursive/deeply nested types)+-- ============================================================================++-- | Maximum nesting depth for CLI representability+maxNestingDepth :: Int+maxNestingDepth = 3++-- | Check if a type is representable within a depth limit+canCLIRepresentWithDepth :: IR -> Int -> TypeRef -> Bool+canCLIRepresentWithDepth _ depth _+ | depth <= 0 = False+canCLIRepresentWithDepth ir depth typeRef = case typeRef of+ RefPrimitive _ _ -> True+ RefOptional inner -> canCLIRepresentWithDepth ir depth inner+ RefArray innerType -> canCLIRepresentWithDepth ir depth innerType+ RefAny -> False+ RefUnknown -> False+ RefNamed qn -> canCLIRepresentNamedWithDepth ir (depth - 1) (qualifiedNameFull qn)++-- | Check named type with depth+canCLIRepresentNamedWithDepth :: IR -> Int -> Text -> Bool+canCLIRepresentNamedWithDepth ir depth name+ | depth <= 0 = False+ | otherwise = case Map.lookup name (irTypes ir) of+ Nothing -> False+ Just TypeDef{..} -> case tdKind of+ KindPrimitive _ _ -> True+ KindAlias target -> canCLIRepresentWithDepth ir depth target+ KindStruct fields -> all (canCLIRepresentFieldWithDepth ir (depth - 1)) fields+ KindEnum "value" _ -> True -- String enum+ KindEnum _ variants -> all (canCLIRepresentVariantWithDepth ir (depth - 1)) variants++-- | Check field with depth+canCLIRepresentFieldWithDepth :: IR -> Int -> FieldDef -> Bool+canCLIRepresentFieldWithDepth ir depth FieldDef{..} =+ canCLIRepresentWithDepth ir depth fdType++-- | Check variant with depth+canCLIRepresentVariantWithDepth :: IR -> Int -> VariantDef -> Bool+canCLIRepresentVariantWithDepth ir depth VariantDef{..} =+ all (canCLIRepresentFieldWithDepth ir depth) vdFields
+ src/Synapse/CLI/Template.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | IR-driven Mustache template generation+--+-- Generates structured Mustache templates directly from the IR, providing:+--+-- - Discriminated union handling with ALL variants in one template+-- - Exhaustive variant coverage (every variant gets a section)+-- - Structured output with labeled fields+--+-- = Design+--+-- Templates are generated per-method with all return type variants visible:+--+-- @+-- IR (types, methods)+-- |+-- +-> generateTemplate -> unified template for a method (all variants)+-- +-> generateAllTemplates -> all templates for a path+-- +-> generateTemplatesFor -> subset of templates (filtered)+-- @+--+-- = Example Output+--+-- For `cone.chat` (streaming enum with variants):+--+-- @+-- {{! cone.chat - returns: ConeEvent }}+-- {{! Variants: start, content, thinking, tool_use, tool_result, complete, error, passthrough }}+--+-- {{#start}}+-- id: {{id}}+-- user_position: {{user_position}}+-- {{/start}}+--+-- {{#content}}{{text}}{{/content}}+--+-- {{#thinking}}{{thinking}}{{/thinking}}+--+-- {{#tool_use}}+-- tool_name: {{tool_name}}+-- tool_use_id: {{tool_use_id}}+-- input: {{input}}+-- {{/tool_use}}+--+-- {{#tool_result}}+-- tool_use_id: {{tool_use_id}}+-- output: {{output}}+-- is_error: {{is_error}}+-- {{/tool_result}}+--+-- {{#complete}}+-- new_head: {{new_head}}+-- usage: {{usage}}+-- {{/complete}}+--+-- {{#error}}{{message}}{{/error}}+--+-- {{#passthrough}}+-- event_type: {{event_type}}+-- data: {{data}}+-- {{/passthrough}}+-- @+module Synapse.CLI.Template+ ( -- * Template Generation+ generateTemplate+ , generateAllTemplates+ , generateTemplatesFor+ , generateAllTemplatesWithCallback++ -- * Type Conversion (exposed for testing/reuse)+ , typeRefToMustache+ , typeDefToMustache+ , variantToMustache++ -- * Types+ , GeneratedTemplate(..)+ , TemplateFilter(..)+ ) where++import Control.Monad.IO.Class (liftIO)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import System.FilePath ((</>), (<.>))++import Synapse.IR.Types+import Synapse.IR.Builder (buildIR)+import Synapse.Monad (SynapseM)+import Synapse.Schema.Types (Path)++-- ============================================================================+-- Types+-- ============================================================================++-- | A generated template with metadata+data GeneratedTemplate = GeneratedTemplate+ { gtNamespace :: Text -- ^ Plugin namespace (e.g., "cone")+ , gtMethod :: Text -- ^ Method name (e.g., "chat")+ , gtTemplate :: Text -- ^ Mustache template content+ , gtPath :: FilePath -- ^ Relative path for template file+ , gtVariants :: [Text] -- ^ List of variant names this template handles+ , gtReturnType :: Maybe Text -- ^ Return type name if named+ }+ deriving stock (Show, Eq)++-- | Filter for selective template generation+data TemplateFilter+ = AllTemplates -- ^ Generate all templates+ | NamespaceFilter [Text] -- ^ Only these namespaces+ | MethodFilter [(Text, Text)] -- ^ Only these (namespace, method) pairs+ | ExcludeFilter [Text] -- ^ Exclude these namespaces+ deriving stock (Show, Eq)++-- ============================================================================+-- High-Level Generation+-- ============================================================================++-- | Generate a unified template for a method's return type+--+-- All variants are included in a single template file.+-- The template is named by method: {namespace}/{method}.mustache+generateTemplate :: IR -> MethodDef -> GeneratedTemplate+generateTemplate ir method =+ let (body, variants, typeName) = generateMethodBody ir method+ header = generateHeader method typeName variants+ template = header <> "\n" <> body+ in GeneratedTemplate+ { gtNamespace = mdNamespace method+ , gtMethod = mdName method+ , gtTemplate = template+ , gtPath = T.unpack (mdNamespace method) </> T.unpack (mdName method) <.> "mustache"+ , gtVariants = variants+ , gtReturnType = typeName+ }++-- | Generate header comment with method info and variant list+generateHeader :: MethodDef -> Maybe Text -> [Text] -> Text+generateHeader method mTypeName variants =+ let typeInfo = maybe "" (\t -> " - returns: " <> t) mTypeName+ variantList = if null variants+ then ""+ else "\n{{! Variants: " <> T.intercalate ", " variants <> " }}"+ in "{{! " <> mdFullPath method <> typeInfo <> " }}" <> variantList++-- | Generate template body for a method, returning (body, variants, typeName)+generateMethodBody :: IR -> MethodDef -> (Text, [Text], Maybe Text)+generateMethodBody ir method = case mdReturns method of+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just typeDef@TypeDef{tdKind = KindEnum _ variants} ->+ -- Union type: generate sections for ALL variants (exhaustive)+ -- No blank lines between sections to avoid whitespace in output+ let variantNames = map vdName variants+ body = T.intercalate "\n" (map (variantToMustache ir 0) variants) <> "\n"+ in (body, variantNames, Just name)+ Just typeDef ->+ -- Non-union named type+ (typeDefToMustache ir 0 typeDef, [], Just name)+ Nothing ->+ -- Type not found+ ("{{.}}", [], Just name)+ other ->+ -- Primitive or other+ (typeRefToMustache ir 0 other, [], Nothing)++-- | Generate all templates by building IR and iterating methods+generateAllTemplates :: Path -> SynapseM [GeneratedTemplate]+generateAllTemplates = generateTemplatesFor AllTemplates++-- | Generate templates with filtering+generateTemplatesFor :: TemplateFilter -> Path -> SynapseM [GeneratedTemplate]+generateTemplatesFor filt path = do+ ir <- buildIR [] path -- No generator info for internal template generation+ let methods = Map.elems (irMethods ir)+ filtered = filterMethods filt methods+ templates = map (generateTemplate ir) filtered+ -- Filter out trivial templates that just render {{.}}+ nonTrivial = filter (not . isTrivialTemplate) templates+ pure nonTrivial++-- | Filter methods based on TemplateFilter+filterMethods :: TemplateFilter -> [MethodDef] -> [MethodDef]+filterMethods AllTemplates methods = methods+filterMethods (NamespaceFilter nss) methods =+ filter (\m -> mdNamespace m `elem` nss) methods+filterMethods (MethodFilter pairs) methods =+ filter (\m -> (mdNamespace m, mdName m) `elem` pairs) methods+filterMethods (ExcludeFilter nss) methods =+ filter (\m -> mdNamespace m `notElem` nss) methods++-- | Generate templates with callback for streaming output+generateAllTemplatesWithCallback+ :: (GeneratedTemplate -> IO ()) -- ^ Called for each template+ -> Path+ -> SynapseM Int -- ^ Returns count+generateAllTemplatesWithCallback callback path = do+ templates <- generateAllTemplates path+ liftIO $ mapM_ callback templates+ pure $ length templates++-- | Check if a template is trivial (just {{.}})+isTrivialTemplate :: GeneratedTemplate -> Bool+isTrivialTemplate gt =+ let body = T.drop 1 $ T.dropWhile (/= '\n') (gtTemplate gt)+ -- Also drop the variants comment line if present+ bodyWithoutComments = T.unlines $ filter (not . isComment) $ T.lines body+ in T.strip bodyWithoutComments == "{{.}}"+ where+ isComment line = "{{!" `T.isPrefixOf` T.strip line++-- ============================================================================+-- Variant to Mustache (Exhaustive)+-- ============================================================================++-- | Convert a variant to a Mustache section+--+-- This ensures EVERY variant gets a section, making the mapping exhaustive.+variantToMustache :: IR -> Int -> VariantDef -> Text+variantToMustache ir indent VariantDef{..} =+ let ind = indentText indent+ sectionName = vdName+ displayFields = filter (not . isInternalField) vdFields+ in case displayFields of+ -- No displayable fields: empty section (still present for exhaustiveness)+ [] -> ind <> "{{#" <> sectionName <> "}}{{/" <> sectionName <> "}}"++ -- Single content-like field: inline rendering (triple braces to avoid HTML escaping)+ [field] | isContentField field ->+ ind <> "{{#" <> sectionName <> "}}{{{" <> fdName field <> "}}}{{/" <> sectionName <> "}}"++ -- Multiple fields: render as labeled lines (no trailing newline)+ fields ->+ let fieldLines = map (generateFieldLine ir (indent + 1)) fields+ openTag = ind <> "{{#" <> sectionName <> "}}"+ closeTag = ind <> "{{/" <> sectionName <> "}}"+ in T.intercalate "\n" $ [openTag] ++ fieldLines ++ [closeTag]++-- ============================================================================+-- Type Reference to Mustache+-- ============================================================================++-- | Convert a TypeRef to Mustache template text+typeRefToMustache :: IR -> Int -> TypeRef -> Text+typeRefToMustache ir indent = \case+ -- Primitives render as the current value+ RefPrimitive _ _ -> "{{.}}"++ -- Named types: look up the definition+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just typeDef -> typeDefToMustache ir indent typeDef+ Nothing -> "{{.}}" -- Fallback if type not found++ -- Arrays: iterate with section+ RefArray inner ->+ let itemTemplate = typeRefToMustache ir (indent + 1) inner+ ind = indentText indent+ in T.unlines+ [ ind <> "{{#.}}"+ , itemTemplate+ , ind <> "{{/.}}"+ ]++ -- Optionals: just render the inner type (mustache handles missing)+ RefOptional inner -> typeRefToMustache ir indent inner++ -- Any/Unknown: fall back to current value+ RefAny -> "{{.}}"+ RefUnknown -> "{{.}}"++-- ============================================================================+-- Type Definition to Mustache+-- ============================================================================++-- | Convert a TypeDef to Mustache template text+typeDefToMustache :: IR -> Int -> TypeDef -> Text+typeDefToMustache ir indent TypeDef{..} = case tdKind of+ -- Discriminated union: render ALL variants as sections (exhaustive)+ KindEnum _discriminator variants ->+ T.intercalate "\n" $ map (variantToMustache ir indent) variants++ -- Struct: render each field+ KindStruct fields ->+ generateStructTemplate ir indent fields++ -- Primitive: just the value+ KindPrimitive _ _ -> "{{.}}"++ -- Alias: follow to target+ KindAlias target -> typeRefToMustache ir indent target++-- ============================================================================+-- Struct Template Generation+-- ============================================================================++-- | Generate template for a struct+generateStructTemplate :: IR -> Int -> [FieldDef] -> Text+generateStructTemplate ir indent fields =+ let displayFields = filter (not . isInternalField) fields+ fieldLines = map (generateFieldLine ir indent) displayFields+ in T.unlines fieldLines++-- ============================================================================+-- Field Generation+-- ============================================================================++-- | Generate a labeled line for a field+generateFieldLine :: IR -> Int -> FieldDef -> Text+generateFieldLine ir indent field@FieldDef{..} =+ let ind = indentText indent+ label = fdName <> ": "+ in case fdType of+ -- For optional fields, show value or explicit "null"+ RefOptional inner ->+ let innerValue = generateOptionalInnerValue ir inner+ in ind <> label <> "{{#" <> fdName <> "}}" <> innerValue <> "{{/" <> fdName <> "}}{{^" <> fdName <> "}}null{{/" <> fdName <> "}}"+ _ ->+ let value = generateFieldValue ir fdType fdName field+ in ind <> label <> value++-- | Generate value for inside an optional section (no outer wrapper needed)+generateOptionalInnerValue :: IR -> TypeRef -> Text+generateOptionalInnerValue ir typeRef = case typeRef of+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just TypeDef{tdKind = KindStruct fields} ->+ let displayFields = filter (not . isInternalField) fields+ fieldRefs = map (\f -> fdName f <> "={{" <> fdName f <> "}}") displayFields+ in T.intercalate " " fieldRefs+ _ -> "{{.}}"+ RefPrimitive _ _ -> "{{.}}"+ _ -> "{{.}}"++-- | Generate the value portion of a field+generateFieldValue :: IR -> TypeRef -> Text -> FieldDef -> Text+generateFieldValue ir typeRef fieldName field = case typeRef of+ -- Primitives: use triple braces for content fields to avoid HTML escaping+ RefPrimitive _ _ ->+ if isContentField field+ then "{{{" <> fieldName <> "}}}"+ else "{{" <> fieldName <> "}}"++ -- Arrays: iterate+ RefArray inner -> case inner of+ RefPrimitive _ _ ->+ "{{#" <> fieldName <> "}}{{.}} {{/" <> fieldName <> "}}"+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just TypeDef{tdKind = KindStruct fields} ->+ -- For arrays of structs, expand each item's fields on its own line+ let displayFields = filter (not . isInternalField) fields+ fieldRefs = map (generateFieldRefInContext ir "") displayFields+ in "{{#" <> fieldName <> "}}\n " <> T.intercalate " " fieldRefs <> "{{/" <> fieldName <> "}}"+ _ ->+ "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}"+ _ ->+ "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}"++ -- Named types: depends on what they are+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just TypeDef{tdKind = KindPrimitive _ _} ->+ "{{" <> fieldName <> "}}"+ Just TypeDef{tdKind = KindStruct fields} ->+ -- Expand struct fields with dot notation to avoid Haskell Show output+ let displayFields = filter (not . isInternalField) fields+ fieldRefs = map (\f -> fdName f <> "={{" <> fieldName <> "." <> fdName f <> "}}") displayFields+ in T.intercalate " " fieldRefs+ Just TypeDef{tdKind = KindEnum _ _} ->+ "{{{" <> fieldName <> "}}}" -- Nested union: use triple braces for unescaped JSON+ _ ->+ "{{" <> fieldName <> "}}"++ -- Optional: wrap in section so null renders nothing+ RefOptional inner -> case inner of+ -- For optional structs, wrap expansion in a section+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in case Map.lookup name (irTypes ir) of+ Just TypeDef{tdKind = KindStruct fields} ->+ let displayFields = filter (not . isInternalField) fields+ fieldRefs = map (\f -> fdName f <> "={{" <> fdName f <> "}}") displayFields+ in "{{#" <> fieldName <> "}}" <> T.intercalate " " fieldRefs <> "{{/" <> fieldName <> "}}"+ _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}"+ -- For optional primitives, simple section+ _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}"++ -- Fallback: use triple braces for content fields+ RefAny ->+ if isContentField field+ then "{{{" <> fieldName <> "}}}"+ else "{{" <> fieldName <> "}}"+ RefUnknown ->+ if isContentField field+ then "{{{" <> fieldName <> "}}}"+ else "{{" <> fieldName <> "}}"++-- ============================================================================+-- Field Reference Generation (for array contexts)+-- ============================================================================++-- | Generate a field reference in the context of an array iteration+-- Recursively expands struct fields using dot notation+-- prefix is the path prefix (empty for top-level array items)+generateFieldRefInContext :: IR -> Text -> FieldDef -> Text+generateFieldRefInContext ir prefix field =+ let name = fdName field+ fullPath = if T.null prefix then name else prefix <> "." <> name+ in case fdType field of+ -- Primitives: simple reference+ RefPrimitive _ _ ->+ name <> "={{" <> fullPath <> "}}"++ -- Named types: check if it's a struct that needs expansion+ RefNamed qn ->+ let typeName = qualifiedNameFull qn+ in case Map.lookup typeName (irTypes ir) of+ Just TypeDef{tdKind = KindStruct fields} ->+ -- Flatten nested struct fields using dot notation (no wrapper)+ let displayFields = filter (not . isInternalField) fields+ dotRefs = map (\f -> fdName f <> "={{" <> fullPath <> "." <> fdName f <> "}}") displayFields+ in T.intercalate " " dotRefs+ Just TypeDef{tdKind = KindPrimitive _ _} ->+ name <> "={{" <> fullPath <> "}}"+ _ ->+ -- Enum or unknown: just reference it+ name <> "={{" <> fullPath <> "}}"++ -- Arrays: indicate it's an array+ RefArray _ ->+ name <> "=[...]"++ -- Optional: same as inner type but may be null+ RefOptional inner -> case inner of+ RefNamed qn ->+ let typeName = qualifiedNameFull qn+ in case Map.lookup typeName (irTypes ir) of+ Just TypeDef{tdKind = KindStruct fields} ->+ -- Flatten nested struct fields using dot notation (no wrapper)+ let displayFields = filter (not . isInternalField) fields+ dotRefs = map (\f -> fdName f <> "={{" <> fullPath <> "." <> fdName f <> "}}") displayFields+ in T.intercalate " " dotRefs+ _ -> name <> "={{" <> fullPath <> "}}"+ _ -> name <> "={{" <> fullPath <> "}}"++ -- Fallback+ _ -> name <> "={{" <> fullPath <> "}}"++-- ============================================================================+-- Field Classification+-- ============================================================================++-- | Check if a field is a "content" field (for inline rendering)+isContentField :: FieldDef -> Bool+isContentField FieldDef{..} = fdName `elem` ["content", "message", "text", "data"]++-- | Check if a field is internal (shouldn't be displayed)+isInternalField :: FieldDef -> Bool+isInternalField FieldDef{..} = fdName `elem` ["type", "event"]++-- ============================================================================+-- Helpers+-- ============================================================================++-- | Generate indentation text+indentText :: Int -> Text+indentText n = T.replicate (n * 2) " "
+ src/Synapse/CLI/Transform.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE RecordWildCards #-}++-- | Parameter transformation layer for CLI+--+-- Provides programmable transformations for command-line parameters before+-- they're parsed by the IR-driven parser. This allows context-aware expansions+-- like path resolution and environment variable substitution.+--+-- = Architecture+--+-- @+-- Command line args+-- ↓+-- parsePathAndParams (extract --key value pairs)+-- ↓+-- [(Text, Text)] raw params+-- ↓+-- transformParams (THIS MODULE - middleware chain)+-- ↓+-- [(Text, Text)] transformed params+-- ↓+-- parseParams (IR-driven type parsing)+-- ↓+-- Value (JSON sent to backend)+-- @+--+-- = Example+--+-- @+-- -- User runs: synapse claudecode create --name test --working_dir .+-- -- Input: [("name", "test"), ("working_dir", ".")]+-- env <- mkTransformEnv+-- transformed <- transformParams env defaultTransformers params+-- -- Output: [("name", "test"), ("working_dir", "/absolute/cwd")]+-- @+module Synapse.CLI.Transform+ ( -- * Transformation Pipeline+ TransformEnv(..)+ , Transformer+ , transformParams+ , mkTransformEnv++ -- * Built-in Transformers+ , pathExpansion+ , envExpansion+ , defaultTransformers++ -- * Smart Defaults (Type-Aware)+ , injectSmartDefaults+ , injectBooleanDefaults+ , isPathParamByType+ , getSmartDefault++ -- * Utilities+ , expandPath+ , isPathParam+ ) where++import Control.Exception (catch, IOException)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import System.Directory (getCurrentDirectory, makeAbsolute, getHomeDirectory)+import System.Environment (getEnvironment)+import System.FilePath (isRelative, (</>))++-- For type-aware smart defaults+import Synapse.IR.Types (IR, MethodDef(..), ParamDef(..), TypeRef(..))++-- ============================================================================+-- Types+-- ============================================================================++-- | Environment available to transformers+data TransformEnv = TransformEnv+ { teCwd :: FilePath -- ^ Current working directory+ , teHome :: Maybe FilePath -- ^ Home directory+ , teEnv :: [(String, String)] -- ^ Environment variables+ }+ deriving (Show, Eq)++-- | A transformer: inspects/modifies parameter pairs+--+-- Transformers are fail-safe: if transformation fails, return original value.+-- The server has authoritative validation, so it's better to pass through+-- potentially-wrong values than to fail CLI invocation.+type Transformer = TransformEnv -> (Text, Text) -> IO (Text, Text)++-- ============================================================================+-- Transformation Pipeline+-- ============================================================================++-- | Apply a chain of transformers to parameter pairs+--+-- Each transformer in the list runs sequentially. Transformers can:+-- - Modify values based on keys+-- - Leave unmatched parameters unchanged+-- - Handle errors gracefully by returning original values+transformParams :: TransformEnv -> [Transformer] -> [(Text, Text)] -> IO [(Text, Text)]+transformParams env transformers params =+ foldl applyTransformer (pure params) transformers+ where+ applyTransformer :: IO [(Text, Text)] -> Transformer -> IO [(Text, Text)]+ applyTransformer mParams transformer = do+ ps <- mParams+ mapM (transformer env) ps++-- | Create transformation environment from system state+mkTransformEnv :: IO TransformEnv+mkTransformEnv = do+ cwd <- getCurrentDirectory+ home <- (Just <$> getHomeDirectory) `catch` \(_ :: IOException) -> pure Nothing+ env <- getEnvironment+ pure TransformEnv+ { teCwd = cwd+ , teHome = home+ , teEnv = env+ }++-- | Default transformer chain+--+-- Applied to all CLI invocations unless disabled.+-- Order matters: earlier transformers run first.+defaultTransformers :: [Transformer]+defaultTransformers =+ [ pathExpansion+ , envExpansion+ ]++-- ============================================================================+-- Path Expansion Transformer+-- ============================================================================++-- | Transform path parameters to absolute paths+--+-- Handles:+-- - @--path .@ → @--path \/absolute\/cwd@+-- - @--path ~\/foo@ → @--path \/home\/user\/foo@+-- - @--working_dir relative@ → @--working_dir \/absolute\/path@+-- - Leaves absolute paths unchanged+--+-- Fail-safe: Returns original value if expansion fails.+pathExpansion :: Transformer+pathExpansion env@TransformEnv{..} (key, val)+ | isPathParam key = do+ expanded <- expandPath teCwd teHome val+ pure (key, expanded)+ | otherwise = pure (key, val)++-- | Check if a parameter name represents a filesystem path+--+-- Add parameter names to this list to enable path expansion for them.+isPathParam :: Text -> Bool+isPathParam k = k `elem`+ [ "path"+ , "working_dir"+ , "output_dir"+ , "file_path"+ , "dir"+ , "directory"+ , "workdir"+ ]++-- | Expand a path string to absolute form+--+-- Handles:+-- - @.@ → current working directory+-- - @~\/foo@ → home directory + foo+-- - @relative\/path@ → cwd + relative\/path+-- - @\/absolute@ → unchanged+--+-- Fail-safe: Returns original path text if expansion fails.+expandPath :: FilePath -> Maybe FilePath -> Text -> IO Text+expandPath cwd mHome pathText = do+ let path = T.unpack pathText+ expanded <- tryExpand path `catch` \(_ :: IOException) -> pure path+ pure $ T.pack expanded+ where+ tryExpand :: FilePath -> IO FilePath+ tryExpand "." = makeAbsolute cwd+ tryExpand ('~':'/':rest) = case mHome of+ Just home -> makeAbsolute (home </> rest)+ Nothing -> pure ('~':'/':rest) -- Can't expand, return as-is+ tryExpand t@('~':_) = pure t -- ~user form not supported+ tryExpand p+ | isRelative p = makeAbsolute (cwd </> p)+ | otherwise = pure p -- Already absolute++-- ============================================================================+-- Environment Variable Expansion+-- ============================================================================++-- | Expand environment variables in parameter values+--+-- Handles:+-- - @--value $VAR@ → @--value \<env_value\>@+-- - @--message \"Hello $USER\"@ → @--message \"Hello alice\"@+--+-- Simple implementation: only expands $VARNAME format (not ${VAR}).+-- Fail-safe: Returns original value if variable not found.+envExpansion :: Transformer+envExpansion TransformEnv{..} (key, val)+ | T.any (== '$') val = do+ let expanded = expandEnvVars teEnv val+ pure (key, expanded)+ | otherwise = pure (key, val)++-- | Expand $VAR references in text+--+-- Uses simple string replacement. Does not handle:+-- - ${VAR} syntax+-- - Default values (${VAR:-default})+-- - Command substitution+--+-- Fail-safe: Leaves $VAR unchanged if not found in environment.+expandEnvVars :: [(String, String)] -> Text -> Text+expandEnvVars env text =+ -- Split on '$' and process each potential variable reference+ let parts = T.splitOn "$" text+ in case parts of+ [] -> text+ (first:rest) -> first <> T.concat (map expandPart rest)+ where+ -- Try to expand a part that comes after '$'+ expandPart :: Text -> Text+ expandPart part =+ let (varName, suffix) = T.span isVarChar part+ in if T.null varName+ then "$" <> part -- No valid var name, keep $+ else case lookup (T.unpack varName) env of+ Just value -> T.pack value <> suffix+ Nothing -> "$" <> part -- Var not found, keep as-is++ -- Characters allowed in environment variable names+ isVarChar :: Char -> Bool+ isVarChar c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_")++-- ============================================================================+-- Smart Defaults (Type-Aware)+-- ============================================================================++-- | Inject smart defaults for missing required parameters+--+-- This is type-aware: it inspects the method's parameter definitions+-- to determine which params are required and what types need defaults.+--+-- Currently supports:+-- - Path parameters (working_dir, path, etc.): Default to current working directory+--+-- Only injects defaults for parameters that are:+-- 1. Required (not optional)+-- 2. Not provided by the user+-- 3. Have a known smart default for their type+--+-- = Example+--+-- @+-- -- User runs: synapse claudecode create --name test --model opus+-- -- Method requires: name, working_dir, model+-- -- User provided: name, model+-- -- Missing: working_dir+--+-- injectSmartDefaults env ir methodDef [(\"name\", \"test\"), (\"model\", \"opus\")]+-- -- Returns: [(\"name\", \"test\"), (\"model\", \"opus\"), (\"working_dir\", \"\/cwd\")]+-- @+injectSmartDefaults :: TransformEnv -> IR -> MethodDef -> [(Text, Text)] -> IO [(Text, Text)]+injectSmartDefaults env _ir methodDef existingParams = do+ let providedKeys = map fst existingParams+ requiredParams = filter pdRequired (mdParams methodDef)+ missingRequired = filter (\p -> pdName p `notElem` providedKeys) requiredParams++ -- For each missing required param, try to inject a smart default+ defaults <- mapM (tryInjectDefault env) missingRequired+ pure $ existingParams ++ catMaybes defaults+ where+ tryInjectDefault :: TransformEnv -> ParamDef -> IO (Maybe (Text, Text))+ tryInjectDefault e param = do+ mDefault <- getSmartDefault e param+ case mDefault of+ Just val -> pure $ Just (pdName param, val)+ Nothing -> pure Nothing++-- | Inject "true" for boolean flags that were present but had no value+--+-- When a user writes @--force@ without a value, parsePathAndParams marks it+-- as @("force", "")@. This function looks at the method definition to determine+-- which empty-value params are actually booleans, and fills them with "true".+--+-- Non-boolean params with empty values are left as-is and will fail validation+-- later with a clear error message.+--+-- = Example+--+-- @+-- -- User runs: synapse cone delete --identifier.type by_name --identifier.name test --force+-- -- Parsed: [("identifier.type", "by_name"), ("identifier.name", "test"), ("force", "")]+-- injectBooleanDefaults ir methodDef params+-- -- Returns: [("identifier.type", "by_name"), ("identifier.name", "test"), ("force", "true")]+-- @+injectBooleanDefaults :: IR -> MethodDef -> [(Text, Text)] -> [(Text, Text)]+injectBooleanDefaults _ir methodDef params =+ map fillBooleanDefault params+ where+ -- Create a map of param names to their definitions for quick lookup+ paramDefMap = [(pdName p, p) | p <- mdParams methodDef]++ fillBooleanDefault :: (Text, Text) -> (Text, Text)+ fillBooleanDefault (key, val)+ -- If value is empty (flag with no value) and param is boolean, fill with "true"+ | val == "", Just paramDef <- lookup key paramDefMap, isBooleanParam paramDef =+ (key, "true")+ -- Otherwise keep as-is+ | otherwise = (key, val)++ -- Check if a parameter is a boolean type (including optional booleans)+ isBooleanParam :: ParamDef -> Bool+ isBooleanParam param = isBooleanType (pdType param)++ isBooleanType :: TypeRef -> Bool+ isBooleanType (RefPrimitive "boolean" _) = True+ isBooleanType (RefOptional inner) = isBooleanType inner+ isBooleanType _ = False++-- | Check if a parameter represents a filesystem path based on type info+--+-- Uses both name heuristics AND type information:+-- - Name matches known path params (working_dir, path, etc.)+-- - Type is string (not UUID, not enum, etc.)+--+-- This is more robust than just checking names, as it avoids false positives+-- like a parameter named \"path\" that's actually a URL or other non-filesystem type.+isPathParamByType :: ParamDef -> Bool+isPathParamByType param =+ let nameMatches = pdName param `elem` pathParamNames+ typeIsString = case pdType param of+ RefPrimitive "string" _ -> True+ RefOptional (RefPrimitive "string" _) -> True+ _ -> False+ in nameMatches && typeIsString+ where+ pathParamNames =+ [ "path"+ , "working_dir"+ , "output_dir"+ , "file_path"+ , "dir"+ , "directory"+ , "workdir"+ ]++-- | Get smart default value for a parameter based on its type+--+-- Returns Nothing if no smart default is available.+-- This is the extensibility point for adding new smart defaults.+--+-- = Current Defaults+--+-- - Path parameters → current working directory+--+-- = Future Extensions+--+-- Could add:+-- - UUID parameters → generated UUID+-- - Timestamp parameters → current time+-- - User name parameters → $USER from environment+getSmartDefault :: TransformEnv -> ParamDef -> IO (Maybe Text)+getSmartDefault env param+ -- Path parameters: use current working directory+ | isPathParamByType param =+ pure $ Just (T.pack $ teCwd env)++ -- Future: UUID parameters could generate fresh UUIDs+ -- | isUuidParam param = Just <$> generateUUID++ -- Future: Timestamp parameters could use current time+ -- | isTimestampParam param = Just <$> getCurrentTimestamp++ -- No smart default available+ | otherwise = pure Nothing
+ src/Synapse/Cache.hs view
@@ -0,0 +1,27 @@+-- | Schema caching by content hash+--+-- Schemas are cached by their hash. Same hash = same content.+-- This enables safe caching: if the hash matches, use cached value.+module Synapse.Cache+ ( -- * Cache Operations (re-exported from Monad)+ lookupCache+ , insertCache++ -- * Cache-aware fetching+ , fetchCached+ ) where++import Synapse.Schema.Types+import Synapse.Monad++-- | Fetch a schema, using cache if available+-- The fetcher function is only called if not in cache+fetchCached :: PluginHash -> SynapseM PluginSchema -> SynapseM PluginSchema+fetchCached hash fetcher = do+ cached <- lookupCache hash+ case cached of+ Just schema -> pure schema+ Nothing -> do+ schema <- fetcher+ insertCache (psHash schema) schema+ pure schema
+ src/Synapse/IR/Builder.hs view
@@ -0,0 +1,716 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | IR Builder - walks schema tree and constructs the IR+--+-- Uses the existing schema walker with a custom algebra that:+-- 1. Extracts types from $defs in methodParams and methodReturns+-- 2. Deduplicates types by content hash (prefer parent namespace, then shortest)+-- 3. Infers streaming from return type structure+-- 4. Builds method definitions with type references+module Synapse.IR.Builder+ ( -- * Building IR+ buildIR++ -- * Extraction (for testing)+ , extractTypesFromSchema+ , extractMethodDef+ , schemaToTypeRef+ ) where++import Control.Monad (forM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Aeson (Value(..))+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import Data.List (minimumBy)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe, catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime, defaultTimeLocale)++import Synapse.Schema.Types+import Synapse.Schema.Functor (SchemaF(..))+import Synapse.Algebra.Walk (walkSchema)+import Synapse.Monad+import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull)+import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion)++-- ============================================================================+-- Building IR+-- ============================================================================++-- | Parse a generator info string "tool:version" into GeneratorInfo+-- Returns Nothing if the format is invalid+parseGeneratorInfo :: Text -> Maybe GeneratorInfo+parseGeneratorInfo s = case T.splitOn ":" s of+ [tool, version] | not (T.null tool) && not (T.null version) ->+ Just $ GeneratorInfo tool version+ _ -> Nothing++-- | Extract V2 hash information from a plugin schema+-- Since Plexus currently only provides a composite 'hash' field,+-- we use it for all three hash fields (backward compatible V1 mode)+extractPluginHashInfo :: PluginSchema -> PluginHashInfo+extractPluginHashInfo schema = PluginHashInfo+ { phiHash = psHash schema+ , phiSelfHash = psHash schema -- V1 fallback: use composite hash+ , phiChildrenHash = psHash schema -- V1 fallback: use composite hash+ }++-- | Build IR by walking the schema tree from a given path+-- After walking, deduplicate types that have identical structure+-- Accepts generator info strings in "tool:version" format+buildIR :: [Text] -> Path -> SynapseM IR+buildIR generatorInfoStrs path = do+ backend <- asks seBackend+ raw <- walkSchema irAlgebra path++ -- Parse generator info and add synapse itself+ let parsedGens = mapMaybe parseGeneratorInfo generatorInfoStrs+ allGens = parsedGens ++ [GeneratorInfo "synapse" synapseVersion]++ -- Get current timestamp in ISO 8601 format+ currentTime <- liftIO getCurrentTime+ let timestamp = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" currentTime++ -- Create generation metadata+ let metadata = GenerationMetadata+ { gmGenerators = allGens+ , gmTimestamp = timestamp+ , gmIrVersion = irVersion emptyIR+ }++ pure $ deduplicateTypes raw+ { irBackend = backend+ , irMetadata = Just metadata+ }++-- | Algebra for building IR from schema tree+--+-- At each node:+-- - Extract types from all methods' params and returns+-- - Build method definitions+-- - Merge with child results+irAlgebra :: SchemaF IR -> SynapseM IR+irAlgebra (PluginF schema path childIRs) = do+ -- Use full path as namespace to avoid collisions+ -- e.g., "hyperforge.workspace.repos" instead of just "repos"+ let namespace = T.intercalate "." path+ pathPrefix = namespace -- Same as namespace++ -- Extract types and methods from this plugin+ let (localTypes, localMethods) = extractFromPlugin namespace pathPrefix schema++ -- Merge with children+ let childIR = foldr mergeIR emptyIR childIRs+ let pluginMethods = map mdName (Map.elems localMethods)++ -- Use this plugin's hash if at root (path is empty)+ let thisHash = if null path+ then Just (psHash schema)+ else irHash childIR++ -- Extract V2 hash information for this plugin+ let hashInfo = extractPluginHashInfo schema+ childHashes = fromMaybe Map.empty (irPluginHashes childIR)+ allHashes = Map.insert namespace hashInfo childHashes++ pure $ IR+ { irVersion = irVersion emptyIR -- Use version from emptyIR+ , irBackend = irBackend emptyIR -- Will be set by buildIR+ , irHash = thisHash+ , irMetadata = irMetadata childIR -- Preserve metadata from child+ , irTypes = Map.union localTypes (irTypes childIR) -- Local wins on conflict+ , irMethods = Map.union localMethods (irMethods childIR)+ , irPlugins = Map.insert namespace pluginMethods (irPlugins childIR)+ , irPluginHashes = Just allHashes -- V2: Store hash info per plugin+ }++irAlgebra (MethodF method namespace path) = do+ -- Single method node (shouldn't happen in normal walk, but handle it)+ let fullPath = T.intercalate "." path+ let (types, mdef) = extractMethodDef namespace fullPath method+ pure $ IR+ { irVersion = irVersion emptyIR -- Use version from emptyIR+ , irBackend = irBackend emptyIR -- Will be set by buildIR+ , irHash = Nothing -- Methods don't carry hash+ , irMetadata = Nothing -- Will be set by buildIR+ , irTypes = types+ , irMethods = Map.singleton fullPath mdef+ , irPlugins = Map.singleton namespace [methodName method]+ , irPluginHashes = Nothing -- Methods don't have plugin-level hashes+ }++-- ============================================================================+-- Type Deduplication+-- ============================================================================++-- | Deduplicate types by content hash+--+-- When multiple namespaces define identical types (e.g., solar.SolarEvent and+-- jupiter.SolarEvent), we deduplicate them by keeping one canonical version.+--+-- Strategy:+-- 1. Hash each TypeDef by its structure (name + kind, ignoring namespace)+-- 2. Group duplicates+-- 3. Pick canonical: prefer parent namespace, then shortest namespace+-- 4. Update all RefNamed references to point to canonical qualified name+deduplicateTypes :: IR -> IR+deduplicateTypes ir =+ let -- Group types by their content hash+ typesByHash = Map.fromListWith (++)+ [ (hashTypeStructure td, [(fullName, td)])+ | (fullName, td) <- Map.toList (irTypes ir)+ ]++ -- Pick canonical version for each group+ canonical = Map.fromList+ [ (hash, selectCanonical group)+ | (hash, group) <- Map.toList typesByHash+ ]++ -- Build redirect map: old qualified name -> canonical qualified name+ redirects = Map.fromList+ [ (oldName, canonicalName)+ | group <- Map.elems typesByHash+ , let canonicalName = fst (selectCanonical group)+ , (oldName, _) <- group+ , oldName /= canonicalName+ ]++ -- Keep only canonical types and update their internal type references+ canonicalPairs = [canon | canon <- Map.elems canonical]+ dedupedTypesWithUpdatedRefs = Map.fromList+ [ (qualName, updateTypeDefRefs redirects td)+ | (qualName, td) <- canonicalPairs+ ]++ -- Update all method references+ dedupedMethods = Map.map (updateMethodRefs redirects) (irMethods ir)++ in ir { irTypes = dedupedTypesWithUpdatedRefs, irMethods = dedupedMethods }++-- | Hash a TypeDef by its structure (ignoring namespace and description)+-- Types are considered identical if they have the same name and kind+-- We normalize TypeRefs (strip namespaces) before hashing to detect structural identity+hashTypeStructure :: TypeDef -> Text+hashTypeStructure TypeDef{..} =+ tdName <> "::" <> T.pack (show (normalizeTypeKind tdKind))+ where+ -- Normalize a TypeKind by stripping namespaces from all RefNamed types+ normalizeTypeKind :: TypeKind -> TypeKind+ normalizeTypeKind = \case+ KindStruct fields -> KindStruct (map normalizeField fields)+ KindEnum disc variants -> KindEnum disc (map normalizeVariant variants)+ KindStringEnum vals -> KindStringEnum vals+ KindAlias target -> KindAlias (normalizeTypeRef target)+ KindPrimitive t f -> KindPrimitive t f++ normalizeField :: FieldDef -> FieldDef+ normalizeField fd = fd { fdType = normalizeTypeRef (fdType fd) }++ normalizeVariant :: VariantDef -> VariantDef+ normalizeVariant vd = vd { vdFields = map normalizeField (vdFields vd) }++ normalizeTypeRef :: TypeRef -> TypeRef+ normalizeTypeRef = \case+ RefNamed qn ->+ -- Strip namespace: keep only local name+ RefNamed qn { qnNamespace = "" }+ RefArray inner -> RefArray (normalizeTypeRef inner)+ RefOptional inner -> RefOptional (normalizeTypeRef inner)+ other -> other++-- | Select the canonical version from a group of duplicate types+-- Strategy: prefer parent namespace, then shortest namespace+selectCanonical :: [(Text, TypeDef)] -> (Text, TypeDef)+selectCanonical dups =+ case dups of+ [] -> error "selectCanonical: empty list"+ [single] -> single+ multiple -> minimumBy compareNamespacePreference multiple+ where+ -- Compare two (fullName, typedef) pairs+ compareNamespacePreference (_, td1) (_, td2) =+ let ns1 = tdNamespace td1+ ns2 = tdNamespace td2+ -- Check if one is parent of the other+ isParent n1 n2 = n2 `T.isPrefixOf` n1 && T.length n1 > T.length n2+ in case (isParent ns1 ns2, isParent ns2 ns1) of+ (True, False) -> GT -- ns2 is parent of ns1, prefer ns2+ (False, True) -> LT -- ns1 is parent of ns2, prefer ns1+ _ -> compare (T.length ns1) (T.length ns2) -- Fallback: shortest wins++-- | Parse a qualified name from a full name string (e.g., "cone.UUID" -> QualifiedName "cone" "UUID")+parseQualifiedName :: Text -> Maybe QualifiedName+parseQualifiedName t =+ case T.breakOnEnd "." t of+ ("", _) -> Nothing -- No dot found+ (ns, local) | T.null local -> Nothing -- Ends with dot+ | otherwise -> Just QualifiedName+ { qnNamespace = T.dropEnd 1 ns -- Remove trailing dot+ , qnLocalName = local+ }++-- | Update all RefNamed references in a method using redirect map+updateMethodRefs :: Map Text Text -> MethodDef -> MethodDef+updateMethodRefs redirects md = md+ { mdParams = map (updateParamRefs redirects) (mdParams md)+ , mdReturns = updateTypeRef redirects (mdReturns md)+ , mdBidirType = fmap (updateTypeRef redirects) (mdBidirType md)+ }++-- | Update type references in a parameter+updateParamRefs :: Map Text Text -> ParamDef -> ParamDef+updateParamRefs redirects pd = pd+ { pdType = updateTypeRef redirects (pdType pd)+ }++-- | Recursively update a TypeRef to use canonical names+updateTypeRef :: Map Text Text -> TypeRef -> TypeRef+updateTypeRef redirects = \case+ RefNamed qn ->+ let fullName = qualifiedNameFull qn+ canonicalName = Map.findWithDefault fullName fullName redirects+ in case parseQualifiedName canonicalName of+ Just qn' -> RefNamed qn'+ Nothing -> RefNamed qn -- Fallback if parse fails+ RefArray inner ->+ RefArray (updateTypeRef redirects inner)+ RefOptional inner ->+ RefOptional (updateTypeRef redirects inner)+ other -> other++-- | Update all type references in a TypeDef+updateTypeDefRefs :: Map Text Text -> TypeDef -> TypeDef+updateTypeDefRefs redirects td = td { tdKind = updateTypeKind (tdKind td) }+ where+ updateTypeKind :: TypeKind -> TypeKind+ updateTypeKind = \case+ KindStruct fields ->+ KindStruct (map updateField fields)+ KindEnum disc variants ->+ KindEnum disc (map updateVariant variants)+ KindAlias target ->+ KindAlias (updateTypeRef redirects target)+ KindStringEnum vals ->+ KindStringEnum vals+ KindPrimitive t f ->+ KindPrimitive t f++ updateField :: FieldDef -> FieldDef+ updateField fd = fd { fdType = updateTypeRef redirects (fdType fd) }++ updateVariant :: VariantDef -> VariantDef+ updateVariant vd = vd { vdFields = map updateField (vdFields vd) }++-- ============================================================================+-- Extraction from Plugin+-- ============================================================================++-- | Extract all types and methods from a plugin schema+-- Types are namespace-qualified to avoid collisions (e.g., "cone.ListResult")+extractFromPlugin :: Text -> Text -> PluginSchema -> (Map Text TypeDef, Map Text MethodDef)+extractFromPlugin namespace pathPrefix schema =+ let methods = psMethods schema+ results = map (extractMethodDef namespace pathPrefix) methods+ allTypes = Map.unions (map fst results)+ allMethods = Map.fromList+ [ (mdFullPath m, m)+ | (_, m) <- results+ ]+ in (allTypes, allMethods)++-- | Extract types and method def from a single method+extractMethodDef :: Text -> Text -> MethodSchema -> (Map Text TypeDef, MethodDef)+extractMethodDef namespace pathPrefix method =+ let name = methodName method+ fullPath = if T.null pathPrefix+ then namespace <> "." <> name+ else pathPrefix <> "." <> name++ -- Extract types from params (namespace-qualified)+ (paramTypes, params) = extractParams namespace (methodParams method)++ -- Extract types from returns (namespace-qualified)+ (returnTypes, returnRef, streaming) = extractReturns namespace name (methodReturns method)++ -- Combine all types+ allTypes = Map.union paramTypes returnTypes++ -- Detect bidirectional type parameter T.+ --+ -- When the schema reports bidirectional: true we know the method uses a+ -- BidirChannel. The 'request_type' field (if present) holds the JSON+ -- Schema for T. We currently emit:+ -- - Nothing → not bidirectional+ -- - Just RefAny → bidirectional with T=Value (StandardBidirChannel,+ -- the default case; request_type is the StandardRequest schema)+ -- - Just (RefNamed …) → bidirectional with a specific named T+ -- (future: when request_type references a named type)+ --+ -- NOTE: The substrate schema as of this implementation always uses+ -- StandardBidirChannel (T=Value), so mdBidirType is always Nothing or+ -- Just RefAny. A future change to MethodSchema / hub-macro that emits a+ -- structured "bidir_type" field (distinct from the full request_type schema)+ -- should be handled here.+ bidirTypeRef = inferBidirType method++ mdef = MethodDef+ { mdName = name+ , mdFullPath = fullPath+ , mdNamespace = namespace+ , mdDescription = Just (methodDescription method)+ , mdStreaming = streaming+ , mdParams = params+ , mdReturns = returnRef+ , mdBidirType = bidirTypeRef+ }+ in (allTypes, mdef)++-- | Infer the bidirectional type parameter from a MethodSchema.+--+-- Returns:+-- Nothing – method is not bidirectional+-- Just RefAny – method is bidirectional with default T=Value (StandardBidirChannel)+-- Just tr – method is bidirectional with specific T type (future)+inferBidirType :: MethodSchema -> Maybe TypeRef+inferBidirType method+ | not (methodBidirectional method) = Nothing+ -- Method is bidirectional. Inspect request_type to determine T.+ | otherwise = case methodRequestType method of+ Nothing ->+ -- bidirectional: true but no request_type schema → treat as T=Value+ Just RefAny+ Just _ ->+ -- request_type is present. For now we always emit RefAny (T=Value)+ -- because the schema emits the full StandardRequest schema rather than+ -- a dedicated "bidir_type" field identifying T.+ --+ -- TODO: When the hub-macro is extended to emit a structured+ -- "bidir_type": { "$ref": "#/$defs/MyType" } field in the schema JSON,+ -- parse it here with schemaToTypeRef and return the resulting TypeRef.+ Just RefAny++-- ============================================================================+-- Parameter Extraction+-- ============================================================================++-- | Extract types and param defs from method params schema+-- Types are namespace-qualified to avoid collisions+extractParams :: Text -> Maybe Value -> (Map Text TypeDef, [ParamDef])+extractParams _ Nothing = (Map.empty, [])+extractParams namespace (Just val) = case val of+ Object o -> extractParamsFromObject namespace o+ _ -> (Map.empty, [])++extractParamsFromObject :: Text -> KM.KeyMap Value -> (Map Text TypeDef, [ParamDef])+extractParamsFromObject namespace o =+ let -- Extract $defs (namespace-qualified)+ defs = extractDefs namespace o++ -- Extract properties+ props = case KM.lookup "properties" o of+ Just (Object p) -> KM.toList p+ _ -> []++ -- Get required list+ required = case KM.lookup "required" o of+ Just (Array arr) -> [t | String t <- V.toList arr]+ _ -> []++ -- Build param defs+ params =+ [ ParamDef+ { pdName = K.toText k+ , pdType = schemaToTypeRef namespace v+ , pdDescription = extractDescription v+ , pdRequired = K.toText k `elem` required+ , pdDefault = extractDefault v+ }+ | (k, v) <- props+ ]+ in (defs, params)++-- ============================================================================+-- Return Type Extraction+-- ============================================================================++-- | Extract types, return ref, and streaming flag from returns schema+extractReturns :: Text -> Text -> Maybe Value -> (Map Text TypeDef, TypeRef, Bool)+extractReturns _ _ Nothing = (Map.empty, RefUnknown, False)+extractReturns namespace methodName (Just val) = case val of+ Object o ->+ let -- Extract $defs+ defs = extractDefs namespace o++ -- Get the type name from title or generate from method name+ typeName = case KM.lookup "title" o of+ Just (String t) -> t+ _ -> methodName <> "Result"++ -- Check for oneOf (discriminated union)+ (typeDef, streaming) = case KM.lookup "oneOf" o of+ Just (Array variants) ->+ let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants)+ discriminator = inferDiscriminator variantDefs+ nonErrorVariants = filter (\v -> vdName v /= "error") variantDefs+ isStream = length nonErrorVariants > 1+ in ( Just $ TypeDef+ { tdName = typeName+ , tdNamespace = namespace+ , tdDescription = extractDescription val+ , tdKind = KindEnum discriminator variantDefs+ }+ , isStream+ )+ _ ->+ -- Not a union, just a regular type+ (Nothing, False)++ -- Add the return type to defs if it's a union+ allDefs = case typeDef of+ Just td -> Map.insert (tdFullName td) td defs+ Nothing -> defs++ -- Return type reference uses QualifiedName+ typeRef = RefNamed QualifiedName+ { qnNamespace = namespace+ , qnLocalName = typeName+ }++ in (allDefs, typeRef, streaming)+ _ -> (Map.empty, RefUnknown, False)++-- | Extract a variant from a oneOf element+extractVariant :: Text -> Value -> Maybe VariantDef+extractVariant namespace (Object o) = case KM.lookup "properties" o of+ Just (Object props) ->+ -- Find the discriminator value (look for "type" with const)+ let discriminatorValue = case KM.lookup "type" props of+ Just (Object typeObj) -> case KM.lookup "const" typeObj of+ Just (String s) -> Just s+ _ -> Nothing+ _ -> Nothing++ -- Extract fields (excluding the discriminator)+ fields =+ [ FieldDef+ { fdName = K.toText k+ , fdType = schemaToTypeRef namespace v+ , fdDescription = extractDescription v+ , fdRequired = True -- In variants, fields are typically required+ , fdDefault = Nothing+ }+ | (k, v) <- KM.toList props+ , K.toText k /= "type" -- Exclude discriminator+ ]+ in case discriminatorValue of+ Just dv -> Just $ VariantDef+ { vdName = dv+ , vdDescription = extractDescription (Object o)+ , vdFields = fields+ }+ Nothing -> Nothing+ _ -> Nothing+extractVariant _ _ = Nothing++-- | Infer the discriminator field name from variants+inferDiscriminator :: [VariantDef] -> Text+inferDiscriminator _ = "type" -- Convention: always "type"++-- | Extract const value from a simple string variant+-- Matches schema like: { "const": "pending", "type": "string", "description": "..." }+extractStringConst :: Value -> Maybe Text+extractStringConst (Object o) =+ case (KM.lookup "const" o, KM.lookup "type" o) of+ (Just (String c), Just (String "string")) -> Just c+ _ -> Nothing+extractStringConst _ = Nothing++-- ============================================================================+-- Type Extraction from $defs+-- ============================================================================++-- | Extract type definitions from $defs or definitions (draft-07 compatibility)+-- Types are namespace-qualified to avoid collisions+extractDefs :: Text -> KM.KeyMap Value -> Map Text TypeDef+extractDefs namespace o =+ let defs = case KM.lookup "$defs" o of+ Just (Object d) -> d+ _ -> case KM.lookup "definitions" o of+ Just (Object d) -> d+ _ -> KM.empty+ in Map.fromList $ mapMaybe (extractTypeDef namespace) (KM.toList defs)++-- | Extract a type definition from a $defs entry+extractTypeDef :: Text -> (K.Key, Value) -> Maybe (Text, TypeDef)+extractTypeDef namespace (k, v) = case v of+ Object o ->+ let name = K.toText k+ desc = extractDescription v+ kind = inferTypeKind namespace o+ td = TypeDef name namespace desc kind+ in Just (tdFullName td, td)+ _ -> Nothing++-- | Infer the kind of a type from its JSON Schema+inferTypeKind :: Text -> KM.KeyMap Value -> TypeKind+inferTypeKind namespace o+ -- Check for oneOf (enum)+ | Just (Array variants) <- KM.lookup "oneOf" o =+ -- First check if this is a simple string enum (all variants are {const: X, type: "string"})+ let maybeStringValues = mapMaybe extractStringConst (V.toList variants)+ in if length maybeStringValues == V.length variants && not (null maybeStringValues)+ then KindStringEnum maybeStringValues+ else let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants)+ in KindEnum "type" variantDefs++ -- Check for enum (simple string enum)+ | Just (Array values) <- KM.lookup "enum" o =+ let stringValues = [ asText v | v <- V.toList values ]+ in KindStringEnum stringValues++ -- Check for object with properties (struct)+ | Just (Object props) <- KM.lookup "properties" o =+ let required = case KM.lookup "required" o of+ Just (Array arr) -> [t | String t <- V.toList arr]+ _ -> []+ fields =+ [ FieldDef+ { fdName = K.toText k+ , fdType = schemaToTypeRef namespace v+ , fdDescription = extractDescription v+ , fdRequired = K.toText k `elem` required+ , fdDefault = extractDefault v+ }+ | (k, v) <- KM.toList props+ ]+ in KindStruct fields++ -- Check for primitive types+ | Just typeVal <- KM.lookup "type" o =+ case typeVal of+ String t -> KindPrimitive t (extractFormat o)+ Array ts ->+ -- Nullable type like ["string", "null"]+ let nonNull = [t | String t <- V.toList ts, t /= "null"]+ in case nonNull of+ [t] -> KindPrimitive t (extractFormat o)+ _ -> KindPrimitive "any" Nothing+ _ -> KindPrimitive "any" Nothing++ -- Default to unknown+ | otherwise = KindPrimitive "any" Nothing++ where+ asText (String s) = s+ asText _ = "unknown"++-- ============================================================================+-- Schema to TypeRef Conversion+-- ============================================================================++-- | Convert a JSON Schema value to a TypeRef+--+-- Distinguishes between:+-- - RefAny: Schema present but no type constraints (intentionally dynamic, e.g. serde_json::Value)+-- - RefUnknown: No schema at all (schema gap, should warn)+--+-- Type references via $ref are namespace-qualified (e.g., "cone.ConeInfo")+schemaToTypeRef :: Text -> Value -> TypeRef+schemaToTypeRef namespace (Object o)+ -- Check for $ref - namespace-qualify the reference+ | Just (String ref) <- KM.lookup "$ref" o =+ RefNamed QualifiedName+ { qnNamespace = namespace+ , qnLocalName = extractRefName ref+ }++ -- Check for array+ | Just (String "array") <- KM.lookup "type" o =+ case KM.lookup "items" o of+ Just items -> RefArray (schemaToTypeRef namespace items)+ Nothing -> RefArray RefAny -- array without items = any[]++ -- Check for nullable+ | Just (Array types) <- KM.lookup "type" o =+ let nonNull = [t | t@(String s) <- V.toList types, s /= "null"]+ hasNull = any (\case String "null" -> True; _ -> False) (V.toList types)+ in case nonNull of+ [String t] ->+ let base = RefPrimitive t (extractFormat o)+ in if hasNull then RefOptional base else base+ _ -> RefAny -- Multiple non-null types = any++ -- Check for anyOf (often used for optional refs) - namespace-qualify refs+ | Just (Array options) <- KM.lookup "anyOf" o =+ let refs = mapMaybe extractRefFromOption (V.toList options)+ in case refs of+ [r] -> RefOptional (RefNamed QualifiedName+ { qnNamespace = namespace+ , qnLocalName = r+ })+ _ -> RefAny -- Complex anyOf = any++ -- Check for primitive type+ | Just (String t) <- KM.lookup "type" o =+ RefPrimitive t (extractFormat o)++ -- Schema object present but no type constraint = intentionally dynamic (RefAny)+ -- This happens with serde_json::Value which emits {"description": "...", "default": null}+ | otherwise = RefAny++-- JSON Schema `true` is the "accept anything" schema - intentionally dynamic+-- This is used when schemars emits a field like `input: true` for serde_json::Value+schemaToTypeRef _ (Bool True) = RefAny++-- Null, false, or non-JSON-Schema values = schema gap (should warn)+schemaToTypeRef _ _ = RefUnknown++-- | Extract ref name from a $ref string like "#/$defs/Position"+extractRefName :: Text -> Text+extractRefName ref = case T.splitOn "/" ref of+ parts | not (null parts) -> last parts+ _ -> ref++-- | Extract ref from anyOf option (for optional types)+extractRefFromOption :: Value -> Maybe Text+extractRefFromOption (Object o) = case KM.lookup "$ref" o of+ Just (String ref) -> Just (extractRefName ref)+ _ -> Nothing+extractRefFromOption _ = Nothing++-- ============================================================================+-- Helpers+-- ============================================================================++-- | Extract description from a schema+extractDescription :: Value -> Maybe Text+extractDescription (Object o) = case KM.lookup "description" o of+ Just (String s) -> Just s+ _ -> Nothing+extractDescription _ = Nothing++-- | Extract default value from a schema+extractDefault :: Value -> Maybe Value+extractDefault (Object o) = KM.lookup "default" o+extractDefault _ = Nothing++-- | Extract format from a schema object+extractFormat :: KM.KeyMap Value -> Maybe Text+extractFormat o = case KM.lookup "format" o of+ Just (String s) -> Just s+ _ -> Nothing++-- | Extract types from a full schema (for standalone use)+-- Types are namespace-qualified+extractTypesFromSchema :: Text -> Value -> Map Text TypeDef+extractTypesFromSchema namespace (Object o) = extractDefs namespace o+extractTypesFromSchema _ _ = Map.empty
+ src/Synapse/IR/Types.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Intermediate Representation for code generation+--+-- The IR is a deduplicated, structured representation of the full+-- plugin graph, optimized for transpilers to consume.+--+-- = Design+--+-- Schema (per-plugin, self-contained, may duplicate types)+-- ↓ walk + transform+-- IR (global, deduplicated, compiler-ready)+-- ↓ transpilers+-- TypeScript / Python / Swift / etc.+--+-- = Structure+--+-- - Types are hoisted to top level and deduplicated by name+-- - Methods reference types by name, not inline definitions+-- - Streaming is inferred from return type structure+-- - Discriminated unions are first-class+module Synapse.IR.Types+ ( -- * Top-level IR+ IR(..)+ , emptyIR+ , mergeIR++ -- * Version Information+ , synapseVersion++ -- * Generation Metadata+ , GeneratorInfo(..)+ , GenerationMetadata(..)++ -- * Plugin Hash Information+ , PluginHashInfo(..)++ -- * Type Definitions+ , TypeDef(..)+ , tdFullName+ , TypeKind(..)+ , FieldDef(..)+ , VariantDef(..)++ -- * Method Definitions+ , MethodDef(..)+ , ParamDef(..)++ -- * Type References+ , QualifiedName(..)+ , qualifiedNameFull+ , TypeRef(..)+ , typeRefName++ -- * Utilities+ , isStreaming+ , inferStreaming+ ) where++import Control.Applicative ((<|>))+import Data.Aeson+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)++-- ============================================================================+-- Version Information+-- ============================================================================++-- | Synapse version (from cabal file: plexus-synapse.cabal)+synapseVersion :: Text+synapseVersion = "0.2.0.0"++-- ============================================================================+-- Generation Metadata+-- ============================================================================++-- | Generator tool version information+data GeneratorInfo = GeneratorInfo+ { giTool :: Text -- ^ Tool name (e.g., "synapse", "synapse-cc")+ , giVersion :: Text -- ^ Version string (e.g., "0.2.0.0")+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)++-- | Generation metadata tracking the full toolchain+data GenerationMetadata = GenerationMetadata+ { gmGenerators :: [GeneratorInfo] -- ^ All tools in the generation chain+ , gmTimestamp :: Text -- ^ ISO 8601 timestamp of generation+ , gmIrVersion :: Text -- ^ IR format version+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)++-- ============================================================================+-- Plugin Hash Information+-- ============================================================================++-- | V2 hash information for a plugin+-- Supports granular cache invalidation by tracking:+-- - Composite hash (backward compatible with V1)+-- - Self hash (methods-only, for detecting method changes)+-- - Children hash (children-only, for detecting dependency changes)+data PluginHashInfo = PluginHashInfo+ { phiHash :: Text -- ^ Composite hash (backward compatible)+ , phiSelfHash :: Text -- ^ V2: Methods-only hash+ , phiChildrenHash :: Text -- ^ V2: Children-only hash+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)++-- ============================================================================+-- Top-level IR+-- ============================================================================++-- | The complete IR for code generation+data IR = IR+ { irVersion :: Text -- ^ IR format version+ , irBackend :: Text -- ^ Backend name (e.g., "substrate", "plexus")+ , irHash :: Maybe Text -- ^ Plexus hash for versioning+ , irMetadata :: Maybe GenerationMetadata -- ^ Generation toolchain metadata+ , irTypes :: Map Text TypeDef -- ^ All types, deduplicated by name+ , irMethods :: Map Text MethodDef -- ^ All methods, keyed by full path (e.g., "cone.chat")+ , irPlugins :: Map Text [Text] -- ^ Plugin -> method names mapping+ , irPluginHashes :: Maybe (Map Text PluginHashInfo) -- ^ V2: Hash information per plugin+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | Empty IR for folding+emptyIR :: IR+emptyIR = IR+ { irVersion = "2.0" -- Bumped: TypeRef now uses structured QualifiedName+ , irBackend = "" -- Will be set by buildIR+ , irHash = Nothing+ , irMetadata = Nothing+ , irTypes = Map.empty+ , irMethods = Map.empty+ , irPlugins = Map.empty+ , irPluginHashes = Nothing+ }++-- | Merge two IRs (for combining results from tree walk)+mergeIR :: IR -> IR -> IR+mergeIR a b = IR+ { irVersion = irVersion a+ , irBackend = irBackend a -- Take from left (parent)+ , irHash = irHash a <|> irHash b -- Take first available hash+ , irMetadata = irMetadata a <|> irMetadata b -- Take first available metadata+ , irTypes = Map.union (irTypes a) (irTypes b) -- Left-biased, first definition wins+ , irMethods = Map.union (irMethods a) (irMethods b)+ , irPlugins = Map.unionWith (++) (irPlugins a) (irPlugins b)+ , irPluginHashes = case (irPluginHashes a, irPluginHashes b) of+ (Just ha, Just hb) -> Just (Map.union ha hb) -- Merge hash maps+ (Just ha, Nothing) -> Just ha+ (Nothing, Just hb) -> Just hb+ (Nothing, Nothing) -> Nothing+ }++-- ============================================================================+-- Type Definitions+-- ============================================================================++-- | A type definition extracted from schemas+data TypeDef = TypeDef+ { tdName :: Text -- ^ Type name (e.g., "ListResult", "ChatEvent")+ , tdNamespace :: Text -- ^ Namespace (e.g., "cone", "arbor")+ , tdDescription :: Maybe Text -- ^ Documentation+ , tdKind :: TypeKind -- ^ What kind of type this is+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | Compute the fully qualified type name+tdFullName :: TypeDef -> Text+tdFullName td = tdNamespace td <> "." <> tdName td++-- | The kind of a type definition+data TypeKind+ = KindStruct+ { ksFields :: [FieldDef] -- ^ Struct fields+ }+ | KindEnum+ { keDiscriminator :: Text -- ^ Field that discriminates (e.g., "type")+ , keVariants :: [VariantDef] -- ^ Possible variants+ }+ | KindStringEnum+ { kseValues :: [Text] -- ^ String literal values (e.g., ["pending", "completed"])+ }+ | KindAlias+ { kaTarget :: TypeRef -- ^ What this aliases to+ }+ | KindPrimitive+ { kpType :: Text -- ^ "string", "integer", "boolean", etc.+ , kpFormat :: Maybe Text -- ^ Optional format hint (e.g., "uuid", "int64")+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | A field in a struct+data FieldDef = FieldDef+ { fdName :: Text -- ^ Field name+ , fdType :: TypeRef -- ^ Field type+ , fdDescription :: Maybe Text -- ^ Documentation+ , fdRequired :: Bool -- ^ Is this field required?+ , fdDefault :: Maybe Value -- ^ Default value if any+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | A variant in a discriminated union+data VariantDef = VariantDef+ { vdName :: Text -- ^ Variant name (the discriminator value)+ , vdDescription :: Maybe Text -- ^ Documentation+ , vdFields :: [FieldDef] -- ^ Fields specific to this variant+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- ============================================================================+-- Method Definitions+-- ============================================================================++-- | A method definition+data MethodDef = MethodDef+ { mdName :: Text -- ^ Method name (e.g., "chat")+ , mdFullPath :: Text -- ^ Full path (e.g., "cone.chat")+ , mdNamespace :: Text -- ^ Parent namespace (e.g., "cone")+ , mdDescription :: Maybe Text -- ^ Documentation+ , mdStreaming :: Bool -- ^ Does this method stream multiple events?+ , mdParams :: [ParamDef] -- ^ Input parameters+ , mdReturns :: TypeRef -- ^ Return type reference+ , mdBidirType :: Maybe TypeRef+ -- ^ Bidirectional channel type parameter T, when the method uses+ -- BidirChannel<StandardRequest<T>, StandardResponse<T>>.+ --+ -- Populated from the "bidirectional" / "request_type" fields in the+ -- MethodSchema (emitted by the hub-macro when #[bidirectional] is set).+ --+ -- - Nothing → method is not bidirectional, OR uses the default+ -- T = serde_json::Value (StandardBidirChannel)+ -- - Just RefAny → bidirectional with T=Value (explicit marker)+ -- - Just (RefNamed ...) → bidirectional with a specific named T type+ --+ -- NOTE: The substrate schema currently emits 'bidirectional: true' but+ -- does not yet include a structured 'bidir_type' field. When that field+ -- is added to MethodSchema, populate it here from methodRequestType.+ -- For now this is always Nothing.+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | A parameter definition+data ParamDef = ParamDef+ { pdName :: Text -- ^ Parameter name+ , pdType :: TypeRef -- ^ Parameter type+ , pdDescription :: Maybe Text -- ^ Documentation+ , pdRequired :: Bool -- ^ Is this required?+ , pdDefault :: Maybe Value -- ^ Default value if any+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- ============================================================================+-- Type References+-- ============================================================================++-- | A qualified name for a type, with namespace and local name+data QualifiedName = QualifiedName+ { qnNamespace :: Text -- ^ Namespace (can be empty for global types)+ , qnLocalName :: Text -- ^ Local name within namespace+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | Get the full qualified name as a single Text+-- Returns just the local name if namespace is empty, otherwise "namespace.localName"+qualifiedNameFull :: QualifiedName -> Text+qualifiedNameFull qn+ | T.null (qnNamespace qn) = qnLocalName qn+ | otherwise = qnNamespace qn <> "." <> qnLocalName qn++-- | A reference to a type+data TypeRef+ = RefNamed QualifiedName -- ^ Reference to a named type (e.g., QualifiedName "cone" "UUID")+ | RefPrimitive Text (Maybe Text) -- ^ Primitive type with optional format+ | RefArray TypeRef -- ^ Array of some type+ | RefOptional TypeRef -- ^ Optional (nullable) type+ | RefAny -- ^ Intentionally dynamic (serde_json::Value) - accepts any JSON+ | RefUnknown -- ^ Unknown type (schema gap) - should warn+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ToJSON)++-- | Get the name from a type reference (if it's a named ref)+typeRefName :: TypeRef -> Maybe Text+typeRefName (RefNamed qn) = Just (qualifiedNameFull qn)+typeRefName _ = Nothing++-- ============================================================================+-- Utilities+-- ============================================================================++-- | Check if a method definition is streaming+isStreaming :: MethodDef -> Bool+isStreaming = mdStreaming++-- | Infer streaming from a return type's structure+-- A method is streaming if its return type is an enum with more than 2 variants+-- (more than 1 success variant + error variant)+inferStreaming :: TypeDef -> Bool+inferStreaming td = case tdKind td of+ KindEnum _ variants ->+ let nonErrorVariants = filter (not . isErrorVariant) variants+ in length nonErrorVariants > 1+ _ -> False+ where+ isErrorVariant v = vdName v == "error"
+ src/Synapse/Monad.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Effect stack for Synapse operations+--+-- = The Monad+--+-- @+-- SynapseM = ExceptT SynapseError (ReaderT SynapseEnv IO)+-- @+--+-- Provides:+-- - Error handling via 'SynapseError'+-- - Environment with cache and cycle detection+-- - IO for network calls+module Synapse.Monad+ ( -- * The Monad+ SynapseM+ , runSynapseM+ , runSynapseM'++ -- * Environment+ , SynapseEnv(..)+ , initEnv+ , defaultEnv++ -- * Errors+ , SynapseError(..)+ , BackendErrorType(..)+ , TransportContext(..)+ , TransportErrorCategory(..)+ , throwNav+ , throwTransport+ , throwTransportWith+ , throwParse+ , throwBackend++ -- * Cycle Detection+ , checkCycle+ , withFreshVisited++ -- * Cache Operations+ , lookupCache+ , insertCache+ ) where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, asks)+import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')+import Data.Text (Text)+import qualified Data.Text as T++import Synapse.Schema.Types+import Synapse.Backend.Discovery (Backend(..))++-- | Environment for Synapse operations+data SynapseEnv = SynapseEnv+ { seHost :: !Text -- ^ Hub host+ , sePort :: !Int -- ^ Hub port+ , seBackend :: !Text -- ^ Backend name (first CLI argument)+ , seCache :: !(IORef (HashMap PluginHash PluginSchema)) -- ^ Schema cache+ , seVisited :: !(IORef (HashSet PluginHash)) -- ^ Cycle detection+ }++-- | Errors that can occur during Synapse operations+data SynapseError+ = NavError NavError+ | TransportError Text -- Keep for compatibility+ | TransportErrorContext TransportContext -- NEW: with context+ | ParseError Text+ | ValidationError Text+ | BackendError BackendErrorType [Backend]+ deriving stock (Show, Eq)++-- | Backend-specific error types+data BackendErrorType+ = BackendNotFound Text+ | BackendUnreachable Text+ | NoBackendsAvailable+ deriving stock (Show, Eq)++-- | Transport error with connection details and categorization+data TransportContext = TransportContext+ { tcMessage :: Text+ , tcHost :: Text+ , tcPort :: Int+ , tcBackend :: Text+ , tcPath :: Path+ , tcCategory :: TransportErrorCategory+ } deriving stock (Show, Eq)++-- | Categories of transport errors+data TransportErrorCategory+ = ConnectionRefused+ | ConnectionTimeout+ | ProtocolError+ | UnknownTransportError+ deriving stock (Show, Eq)++-- | The Synapse monad stack+newtype SynapseM a = SynapseM+ { unSynapseM :: ExceptT SynapseError (ReaderT SynapseEnv IO) a+ }+ deriving newtype+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadReader SynapseEnv+ , MonadError SynapseError+ )++-- Note: PluginHash is a type alias for Text, which is already Hashable++-- | Run a SynapseM action with the given environment+runSynapseM :: SynapseEnv -> SynapseM a -> IO (Either SynapseError a)+runSynapseM env action = runReaderT (runExceptT (unSynapseM action)) env++-- | Run a SynapseM action with default host/port and specified backend+runSynapseM' :: Text -> SynapseM a -> IO (Either SynapseError a)+runSynapseM' backend action = do+ env <- defaultEnv backend+ runSynapseM env action++-- | Initialize environment with given host/port/backend+initEnv :: Text -> Int -> Text -> IO SynapseEnv+initEnv host port backend = do+ cache <- newIORef HM.empty+ visited <- newIORef HS.empty+ pure SynapseEnv+ { seHost = host+ , sePort = port+ , seBackend = backend+ , seCache = cache+ , seVisited = visited+ }++-- | Default environment (localhost:4444, requires backend)+defaultEnv :: Text -> IO SynapseEnv+defaultEnv = initEnv "127.0.0.1" 4444++-- | Throw a navigation error+throwNav :: NavError -> SynapseM a+throwNav = throwError . NavError++-- | Throw a transport error+throwTransport :: Text -> SynapseM a+throwTransport = throwError . TransportError++-- | Throw a parse error+throwParse :: Text -> SynapseM a+throwParse = throwError . ParseError++-- | Throw a backend error+throwBackend :: BackendErrorType -> [Backend] -> SynapseM a+throwBackend errorType backends = throwError (BackendError errorType backends)++-- | Throw a transport error with context+throwTransportWith :: TransportContext -> SynapseM a+throwTransportWith = throwError . TransportErrorContext++-- ============================================================================+-- Cycle Detection+-- ============================================================================++-- | Check for cycles before descending into a child+-- Throws 'Cycle' error if hash was already visited+checkCycle :: PluginHash -> Path -> SynapseM ()+checkCycle hash path = do+ visitedRef <- asks seVisited+ visited <- liftIO $ readIORef visitedRef+ when (hash `HS.member` visited) $+ throwNav $ Cycle hash path+ liftIO $ modifyIORef' visitedRef (HS.insert hash)++-- | Run an action with a fresh visited set, restoring afterwards+-- Used at the start of each navigation to reset cycle detection+withFreshVisited :: SynapseM a -> SynapseM a+withFreshVisited action = do+ ref <- asks seVisited+ old <- liftIO $ readIORef ref+ liftIO $ writeIORef ref HS.empty+ result <- action+ liftIO $ writeIORef ref old+ pure result++-- ============================================================================+-- Cache Operations+-- ============================================================================++-- | Look up a schema in the cache by hash+lookupCache :: PluginHash -> SynapseM (Maybe PluginSchema)+lookupCache hash = do+ cacheRef <- asks seCache+ cache <- liftIO $ readIORef cacheRef+ pure $ HM.lookup hash cache++-- | Insert a schema into the cache+insertCache :: PluginHash -> PluginSchema -> SynapseM ()+insertCache hash schema = do+ cacheRef <- asks seCache+ liftIO $ modifyIORef' cacheRef (HM.insert hash schema)
+ src/Synapse/Renderer.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Template-based output renderer+--+-- Runtime-configurable output rendering using Mustache templates.+-- Templates are resolved by METHOD name (not content_type), supporting+-- unified templates with all variants visible.+--+-- = Template Resolution+--+-- Templates are searched in order:+-- 1. Project-local: @.substrate/templates/{namespace}/{method}.mustache@+-- 2. User global: @~/.config/synapse/templates/{namespace}/{method}.mustache@+-- 3. Built-in defaults+--+-- = Method Hints+--+-- When a method path is set via 'withMethodPath', template lookup uses+-- that path instead of parsing the content_type. This allows unified+-- templates that handle all variants of a method's return type.+--+-- = Usage+--+-- @+-- cfg <- defaultRendererConfig+-- let cfg' = withMethodPath cfg ["cone", "chat"]+-- result <- renderItem cfg' item+-- case result of+-- Just text -> TIO.putStrLn text+-- Nothing -> printJson item -- fallback+-- @+module Synapse.Renderer+ ( -- * Configuration+ RendererConfig(..)+ , defaultRendererConfig+ , withMethodPath+ , OutputMode(..)++ -- * Rendering+ , renderItem+ , renderValue+ , renderWithTemplate+ , prettyValue++ -- * Template Resolution+ , resolveTemplate+ , resolveTemplateForMethod+ , templateSearchPaths++ -- * Template Loading+ , loadTemplate+ , TemplateCache+ , newTemplateCache+ , getCachedTemplate+ ) where++import Control.Exception (catch, SomeException)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (Value(..), encode)+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IORef+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific, floatingOrInteger)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import System.Directory (doesFileExist, getCurrentDirectory, getHomeDirectory)+import System.FilePath ((</>), (<.>))+import Text.Mustache (Template, toMustache)+import Text.Mustache.Compile (localAutomaticCompile)+import Text.Mustache.Render (substituteValue)+import qualified Text.Mustache.Types as MT++import Synapse.Schema.Types+ ( HubStreamItem+ , pattern HubData+ , pattern HubProgress+ , pattern HubError+ , pattern HubDone+ )++-- ============================================================================+-- Types+-- ============================================================================++-- | Output mode for rendering+data OutputMode+ = ModeTemplate -- ^ Use templates when available+ | ModeJson -- ^ Raw JSON stream items+ | ModeRaw -- ^ Just the content value+ deriving stock (Show, Eq)++-- | Renderer configuration+data RendererConfig = RendererConfig+ { rcSearchPaths :: [FilePath] -- ^ Template search paths+ , rcMode :: OutputMode -- ^ Output mode+ , rcCache :: TemplateCache -- ^ Template cache+ , rcMethodPath :: Maybe [Text] -- ^ Method path hint for template lookup+ }++-- | Template cache to avoid re-parsing+newtype TemplateCache = TemplateCache (IORef (Map FilePath Template))++-- ============================================================================+-- Configuration+-- ============================================================================++-- | Create a new template cache+newTemplateCache :: IO TemplateCache+newTemplateCache = TemplateCache <$> newIORef Map.empty++-- | Get default renderer configuration+defaultRendererConfig :: IO RendererConfig+defaultRendererConfig = do+ paths <- templateSearchPaths+ cache <- newTemplateCache+ pure $ RendererConfig+ { rcSearchPaths = paths+ , rcMode = ModeTemplate+ , rcCache = cache+ , rcMethodPath = Nothing+ }++-- | Set the method path for template resolution+--+-- When set, template lookup will use this path instead of parsing+-- the content_type. This allows unified templates that handle all+-- variants of a method's return type.+--+-- Example: @withMethodPath cfg ["cone", "chat"]@ will look for+-- @cone/chat.mustache@ regardless of the content_type.+withMethodPath :: RendererConfig -> [Text] -> RendererConfig+withMethodPath cfg path = cfg { rcMethodPath = Just path }++-- | Get template search paths+templateSearchPaths :: IO [FilePath]+templateSearchPaths = do+ cwd <- getCurrentDirectory+ home <- getHomeDirectory+ pure+ [ cwd </> ".substrate" </> "templates"+ , home </> ".config" </> "synapse" </> "templates"+ ]++-- ============================================================================+-- Template Resolution+-- ============================================================================++-- | Resolve template path for a method path+--+-- Search order:+-- 1. {searchPath}/{namespace}/{method}.mustache (exact match)+-- 2. {searchPath}/{namespace}/default.mustache (namespace default)+-- 3. {searchPath}/default.mustache (global default)+resolveTemplateForMethod :: RendererConfig -> [Text] -> IO (Maybe FilePath)+resolveTemplateForMethod cfg methodPath = case methodPath of+ [] -> pure Nothing+ [method] -> resolveTemplateByParts cfg "default" method+ parts ->+ let namespace = T.intercalate "." (init parts)+ method = last parts+ in resolveTemplateByParts cfg namespace method++-- | Resolve template by namespace and method parts+resolveTemplateByParts :: RendererConfig -> Text -> Text -> IO (Maybe FilePath)+resolveTemplateByParts cfg namespace method = do+ let candidates =+ -- Exact method match+ [ path </> T.unpack namespace </> T.unpack method <.> "mustache"+ | path <- rcSearchPaths cfg+ ]+ -- Namespace default+ ++ [ path </> T.unpack namespace </> "default" <.> "mustache"+ | path <- rcSearchPaths cfg+ ]+ -- Global default+ ++ [ path </> "default.mustache" | path <- rcSearchPaths cfg ]+ firstExisting candidates++-- | Resolve template path for a content type (legacy, fallback)+--+-- Content type format: "namespace.variant" (e.g., "cone.start", "health.status")+-- This is used when no method path hint is set.+resolveTemplate :: RendererConfig -> Text -> IO (Maybe FilePath)+resolveTemplate cfg contentType =+ case rcMethodPath cfg of+ -- Method path hint available: use it+ Just methodPath -> resolveTemplateForMethod cfg methodPath+ -- No hint: fall back to content_type parsing+ Nothing -> do+ let (namespace, method) = parseContentType contentType+ resolveTemplateByParts cfg namespace method++-- | Parse content_type into (namespace, method/variant)+parseContentType :: Text -> (Text, Text)+parseContentType ct = case T.splitOn "." ct of+ [ns, m] -> (ns, m)+ [m] -> ("default", m)+ parts -> (T.intercalate "." (init parts), last parts)++-- | Find first existing file from candidates+firstExisting :: [FilePath] -> IO (Maybe FilePath)+firstExisting [] = pure Nothing+firstExisting (p:ps) = do+ exists <- doesFileExist p+ if exists then pure (Just p) else firstExisting ps++-- ============================================================================+-- Template Loading+-- ============================================================================++-- | Load a template from disk+loadTemplate :: FilePath -> IO (Either Text Template)+loadTemplate path = do+ result <- localAutomaticCompile path+ case result of+ Left err -> pure $ Left $ T.pack $ show err+ Right template -> pure $ Right template++-- | Get template from cache, loading if needed+getCachedTemplate :: RendererConfig -> FilePath -> IO (Either Text Template)+getCachedTemplate cfg path = do+ let TemplateCache cacheRef = rcCache cfg+ cache <- readIORef cacheRef+ case Map.lookup path cache of+ Just template -> pure $ Right template+ Nothing -> do+ result <- loadTemplate path+ case result of+ Right template -> do+ modifyIORef' cacheRef (Map.insert path template)+ pure $ Right template+ Left err -> pure $ Left err++-- ============================================================================+-- Rendering+-- ============================================================================++-- | Render a stream item using templates+renderItem :: RendererConfig -> HubStreamItem -> IO (Maybe Text)+renderItem cfg item = case rcMode cfg of+ ModeJson -> pure Nothing -- Caller should use JSON+ ModeRaw -> pure Nothing -- Caller should extract content+ ModeTemplate -> case item of+ HubData _ _ contentType content ->+ renderValue cfg contentType content+ HubProgress _ _ msg _ ->+ pure $ Just msg+ HubError _ _ err _ ->+ pure $ Just $ "Error: " <> err+ HubDone _ _ ->+ pure Nothing+ _ -> pure Nothing -- Handle other variants (e.g., HubGuidance)++-- | Render a value using template for content type+renderValue :: RendererConfig -> Text -> Value -> IO (Maybe Text)+renderValue cfg contentType value = do+ mPath <- resolveTemplate cfg contentType+ case mPath of+ Nothing -> pure Nothing+ Just path -> do+ result <- getCachedTemplate cfg path+ case result of+ Left _err -> pure Nothing+ Right template -> pure $ Just $ renderWithTemplate template value++-- | Render a value with a specific template+renderWithTemplate :: Template -> Value -> Text+renderWithTemplate template value =+ let wrapped = wrapDiscriminatedUnion value+ in substituteValue template (toMustache wrapped)++-- | Wrap discriminated union data for mustache template compatibility+--+-- Templates expect variant data wrapped like: {"echo": {"count": 1, ...}}+-- But actual responses are flat: {"type": "echo", "count": 1, ...}+--+-- This transforms flat discriminated unions into wrapped form so+-- mustache sections like {{#echo}}...{{/echo}} will match.+wrapDiscriminatedUnion :: Value -> Value+wrapDiscriminatedUnion (Object obj) =+ case KM.lookup "type" obj of+ Just (String variant) ->+ -- Wrap: {"variant": original_object}+ Object $ KM.singleton (K.fromText variant) (Object obj)+ _ -> Object obj+wrapDiscriminatedUnion other = other++-- ============================================================================+-- Pretty Printing+-- ============================================================================++-- | Pretty-print a JSON value in human-readable format (no JSON syntax)+prettyValue :: Value -> Text+prettyValue = prettyIndent 0++prettyIndent :: Int -> Value -> Text+prettyIndent indent val = case val of+ Null -> "null"+ Bool True -> "true"+ Bool False -> "false"+ Number n -> case floatingOrInteger n of+ Left d -> T.pack $ show (d :: Double)+ Right i -> T.pack $ show (i :: Integer)+ String s -> s+ Array arr+ | V.null arr -> "[]"+ | otherwise -> T.intercalate "\n" $+ map (\v -> spaces <> "- " <> prettyInline v) (V.toList arr)+ Object obj+ | KM.null obj -> "{}"+ | otherwise -> T.intercalate "\n" $+ map (\(k, v) -> spaces <> K.toText k <> ": " <> prettyChild v) (KM.toList obj)+ where+ spaces = T.replicate indent " "++ -- For array items and object values, decide inline vs block+ prettyChild v = case v of+ Object o | not (KM.null o) -> "\n" <> prettyIndent (indent + 1) v+ Array a | not (V.null a) -> "\n" <> prettyIndent (indent + 1) v+ _ -> prettyInline v++ -- Inline rendering for simple values+ prettyInline v = case v of+ Null -> "null"+ Bool True -> "true"+ Bool False -> "false"+ Number n -> case floatingOrInteger n of+ Left d -> T.pack $ show (d :: Double)+ Right i -> T.pack $ show (i :: Integer)+ String s -> s+ Array arr -> T.intercalate ", " $ map prettyInline (V.toList arr)+ Object obj -> T.intercalate ", " $+ map (\(k, v') -> K.toText k <> ": " <> prettyInline v') (KM.toList obj)
+ src/Synapse/Schema/Functor.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Base functor for schema trees+--+-- This module defines the "shape" of one layer of a schema tree,+-- enabling proper recursion schemes (ana/cata/hylo).+--+-- = The Functor+--+-- @+-- data SchemaF a+-- = PluginF PluginSchema [a] -- interior node: plugin with children+-- | MethodF MethodSchema Text -- leaf: method with namespace+-- @+--+-- The type parameter 'a' represents "what's in the recursive positions".+-- For a tree, 'a' would be the subtrees. For a fold result, 'a' would be+-- the accumulated value from children.+--+-- = Fixed Point+--+-- The fixed point @Fix SchemaF@ gives us the infinite tree type:+--+-- @+-- type SchemaTree = Fix SchemaF+-- @+--+-- This is isomorphic to a tree where every node is either a plugin+-- (with children) or a method (leaf).+module Synapse.Schema.Functor+ ( -- * Base Functor+ SchemaF(..)++ -- * Fixed Point+ , Fix(..)+ , SchemaTree++ -- * Seed for unfolding+ , SchemaSeed(..)++ -- * Accessors+ , nodeNamespace+ , nodeMethods+ ) where++import Data.Text (Text)++import Synapse.Schema.Types (PluginSchema(..), MethodSchema(..), Path)++-- | Fixed point of a functor+--+-- @Fix f@ is the type where @f@ refers to itself in recursive positions.+-- Unrolling: @Fix f ≅ f (Fix f) ≅ f (f (Fix f)) ≅ ...@+newtype Fix f = Fix { unFix :: f (Fix f) }++deriving instance Show (f (Fix f)) => Show (Fix f)+deriving instance Eq (f (Fix f)) => Eq (Fix f)++-- | Base functor for schema trees+--+-- Captures the "shape" of one layer:+-- - PluginF: interior node with plugin info and child positions+-- - MethodF: leaf with method info and parent namespace+data SchemaF a+ = PluginF+ { sfSchema :: PluginSchema -- ^ The plugin schema at this node+ , sfPath :: Path -- ^ Path to this node+ , sfChildren :: [a] -- ^ Recursive positions (children)+ }+ | MethodF+ { sfMethod :: MethodSchema -- ^ The method schema+ , sfNamespace :: Text -- ^ Parent namespace+ , sfMethodPath :: Path -- ^ Full path to this method+ }+ deriving stock (Functor, Foldable, Traversable, Show, Eq)++-- | The fixed point gives us schema trees+type SchemaTree = Fix SchemaF++-- | Seed for anamorphic unfolding+-- Contains the path to fetch and any context needed+data SchemaSeed = SchemaSeed+ { seedPath :: Path+ }+ deriving stock (Show, Eq)++-- | Get the namespace from a schema node+nodeNamespace :: SchemaF a -> Text+nodeNamespace (PluginF schema _ _) = psNamespace schema+nodeNamespace (MethodF _ ns _) = ns++-- | Get methods from a plugin node (empty for method nodes)+nodeMethods :: SchemaF a -> [MethodSchema]+nodeMethods (PluginF schema _ _) = psMethods schema+nodeMethods (MethodF _ _ _) = []
+ src/Synapse/Schema/Types.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE PatternSynonyms #-}++-- | Core types for Synapse+--+-- Re-exports schema types from plexus-protocol and defines local types.+module Synapse.Schema.Types+ ( -- * Schema Types (from plexus-protocol)+ PluginSchema(..)+ , MethodSchema(..)+ , ChildSummary(..)+ , PluginHash+ , SchemaResult(..)++ -- * Query helpers+ , pluginChildren+ , childNamespaces+ , isHubActivation+ , isLeafActivation++ -- * Navigation Types+ , Path+ , SchemaView(..)+ , NavError(..)++ -- * Stream Types+ , StreamMeta(..)++ -- * Hub Protocol Types+ -- | Re-exported from Plexus.Types with Hub naming+ , HubStreamItem+ , pattern HubData+ , pattern HubProgress+ , pattern HubError+ , pattern HubDone+ , pattern HubGuidance+ , pattern HubRequest++ -- * Bidirectional Types (re-exported)+ , Request(..)+ , StandardRequest+ , Response(..)+ , StandardResponse+ , SelectOption(..)+ ) where++import Data.Aeson (Value)+import Data.Text (Text)+import Data.Int (Int64)+import GHC.Generics (Generic)++-- Re-export from plexus-protocol+import Plexus.Schema.Recursive+ ( PluginSchema(..)+ , MethodSchema(..)+ , ChildSummary(..)+ , PluginHash+ , SchemaResult(..)+ , pluginChildren+ , childNamespaces+ , isHubActivation+ , isLeafActivation+ )++import Plexus.Types+ ( PlexusStreamItem(..)+ , Provenance+ , GuidanceErrorType+ , GuidanceSuggestion+ , Request(..)+ , StandardRequest+ , Response(..)+ , StandardResponse+ , SelectOption(..)+ )++-- | A path through the plugin tree (sequence of namespace segments)+type Path = [Text]++-- | A position in the schema tree after navigation+data SchemaView+ = ViewPlugin PluginSchema Path -- ^ Landed on a plugin, path taken to get here+ | ViewMethod MethodSchema Path -- ^ Landed on a method, path taken to get here+ deriving stock (Show, Eq)++-- | Navigation errors+data NavError+ = NotFound Text Path (Maybe PluginSchema) -- ^ Segment not found at path (with schema context)+ | MethodNotTerminal Text Path -- ^ Method with trailing path segments+ | Cycle PluginHash Path -- ^ Cycle detected (hash seen before)+ | FetchError Text Path -- ^ Failed to fetch schema+ deriving stock (Show, Eq)++-- | Metadata from stream events+data StreamMeta = StreamMeta+ { smProvenance :: [Text]+ , smHash :: PluginHash+ , smTimestamp :: Int64+ }+ deriving stock (Show, Eq, Generic)++-- ============================================================================+-- Hub Protocol Types (re-exported from Plexus.Types with Hub naming)+-- ============================================================================++-- | Hub stream item - the universal transport envelope for streaming responses+--+-- This is a type alias for 'PlexusStreamItem' from the protocol layer,+-- renamed to use Hub terminology at the application level.+type HubStreamItem = PlexusStreamItem++-- | Pattern synonym for data events+pattern HubData :: Text -> Provenance -> Text -> Value -> HubStreamItem+pattern HubData hash prov contentType content = StreamData hash prov contentType content++-- | Pattern synonym for progress events+pattern HubProgress :: Text -> Provenance -> Text -> Maybe Double -> HubStreamItem+pattern HubProgress hash prov msg pct = StreamProgress hash prov msg pct++-- | Pattern synonym for error events+pattern HubError :: Text -> Provenance -> Text -> Bool -> HubStreamItem+pattern HubError hash prov err recoverable = StreamError hash prov err recoverable++-- | Pattern synonym for done events+pattern HubDone :: Text -> Provenance -> HubStreamItem+pattern HubDone hash prov = StreamDone hash prov++-- | Pattern synonym for guidance events+pattern HubGuidance :: Text -> Provenance -> GuidanceErrorType -> GuidanceSuggestion -> Maybe [Text] -> Maybe Value -> HubStreamItem+pattern HubGuidance hash prov errType suggestion methods schema = StreamGuidance hash prov errType suggestion methods schema++-- | Pattern synonym for bidirectional request events+pattern HubRequest :: Text -> Provenance -> Text -> Request Value -> Int -> HubStreamItem+pattern HubRequest hash prov reqId reqData timeout = StreamRequest hash prov reqId reqData timeout
+ src/Synapse/Self/Commands.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Command dispatcher for _self meta-commands+--+-- _self commands are client-side only and don't make RPC calls.+-- They operate on cached schemas and provide meta-functionality+-- like template generation, schema exploration, etc.+module Synapse.Self.Commands+ ( dispatch+ , showHelp+ ) where++import Control.Concurrent.Async (mapConcurrently)+import Control.Exception (SomeException, catch)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Synapse.Monad+import Synapse.Backend.Discovery (getBackendAt)+import qualified Synapse.Self.Template as Template++-- | Dispatch to a specific _self subcommand+dispatch :: Text -> [Text] -> [(Text, Text)] -> SynapseM ()+dispatch "template" rest params = Template.handleTemplate rest params+dispatch "scan" rest _ = scanPorts rest+dispatch "--help" _ _ = showHelp+dispatch "-h" _ _ = showHelp+dispatch cmd _ _ =+ throwParse $ "Unknown _self command: " <> cmd <> "\n\n" <> helpText++-- | Scan ports for backends+-- Default range: 4440-4459 (covers 444x range)+scanPorts :: [Text] -> SynapseM ()+scanPorts _ = do+ host <- asks seHost+ liftIO $ TIO.putStrLn $ "Scanning " <> host <> " ports 4440-4459 for backends...\n"++ -- Scan ports in parallel+ let ports = [4440..4459]+ results <- liftIO $ mapConcurrently (probePort host) ports++ -- Display results+ let found = filter (\(_, mb) -> mb /= Nothing) (zip ports results)+ if null found+ then liftIO $ TIO.putStrLn "No backends found"+ else do+ liftIO $ TIO.putStrLn $ "Found " <> T.pack (show (length found)) <> " backend(s):\n"+ liftIO $ mapM_ printResult found+ where+ probePort :: Text -> Int -> IO (Maybe Text)+ probePort host port =+ getBackendAt host port `catch` \(_ :: SomeException) -> pure Nothing++ printResult :: (Int, Maybe Text) -> IO ()+ printResult (port, Just name) =+ TIO.putStrLn $ " " <> T.pack (show port) <> " " <> name+ printResult _ = pure ()++-- | Show help for _self commands+showHelp :: SynapseM ()+showHelp = liftIO $ TIO.putStr helpText++-- | Help text for _self commands+helpText :: Text+helpText = T.unlines+ [ "Meta-commands (local, no RPC):"+ , ""+ , "Available commands:"+ , ""+ , " synapse _self scan"+ , " Scan ports 4440-4459 for backends (calls _info on each)"+ , ""+ , " synapse _self template"+ , " Manage Mustache templates (CRUD operations)"+ , ""+ , " Subcommands:"+ , " list [pattern] - List existing templates"+ , " show <method> - Display template content"+ , " generate [pattern] - Generate new templates from IR"+ , " delete <pattern> - Delete templates matching pattern"+ , " reload - Clear template cache"+ , ""+ , " Pattern format: backend.namespace.method"+ , " Examples: 'plexus.cone.*', 'plexus.*.create'"+ , ""+ , "Examples:"+ , " synapse _self scan"+ , " synapse _self template list"+ , " synapse _self template show cone.chat"+ , " synapse _self template generate 'plexus.cone.*'"+ , " synapse _self template delete 'plexus.cone.test'"+ , ""+ , "Templates location: ~/.config/synapse/templates/"+ , ""+ , "Use 'synapse _self template' for detailed template help"+ , ""+ ]
+ src/Synapse/Self/Examples.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Example value generation for CLI templates+--+-- Generates realistic example values for different TypeRefs+-- to populate CLI command templates.+module Synapse.Self.Examples+ ( generateExampleValue+ , generateExampleParam+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Map.Strict as Map+import Synapse.IR.Types++-- | Generate a realistic example value for a TypeRef+-- Returns the value in a format suitable for CLI usage+generateExampleValue :: IR -> TypeRef -> Text+generateExampleValue ir typeRef = case typeRef of+ -- Primitives with format hints+ RefPrimitive "string" (Just "uuid") ->+ "550e8400-e29b-41d4-a716-446655440000"+ RefPrimitive "string" (Just "date-time") ->+ "2026-01-21T10:30:00Z"+ RefPrimitive "string" _ ->+ "example"+ RefPrimitive "integer" _ -> "42"+ RefPrimitive "number" _ -> "3.14"+ RefPrimitive "boolean" _ -> "true"++ -- Named types - look up in IR+ RefNamed qn -> case lookupTypeDef ir qn of+ Just typeDef -> generateNamedTypeExample ir typeDef+ Nothing -> "{}" -- Unknown type++ -- Collections and modifiers+ RefArray inner ->+ "'[" <> generateExampleValue ir inner <> "]'"+ RefOptional inner ->+ generateExampleValue ir inner+ RefAny -> "{}"+ RefUnknown -> "<value>"++-- | Generate example for a named type definition+generateNamedTypeExample :: IR -> TypeDef -> Text+generateNamedTypeExample ir typeDef = case tdKind typeDef of+ -- String enums - show first value+ KindStringEnum values -> case values of+ (v:_) -> "\"" <> v <> "\""+ [] -> "\"value\""++ -- Discriminated unions - show first variant as JSON+ KindEnum disc variants -> case variants of+ (v:_) -> formatVariantExample ir disc v+ [] -> "{}"++ -- Structs - show empty object with hint+ KindStruct _ -> "{}"++ -- Aliases - resolve to target+ KindAlias target -> generateExampleValue ir target++ -- Primitives+ KindPrimitive ptype fmt -> generateExampleValue ir (RefPrimitive ptype fmt)++-- | Format a discriminated union variant as JSON+formatVariantExample :: IR -> Text -> VariantDef -> Text+formatVariantExample ir disc variant =+ let typeField = "\\\"" <> disc <> "\\\":\\\"" <> vdName variant <> "\\\""+ fieldExamples = map (formatFieldExample ir) (vdFields variant)+ allFields = typeField : fieldExamples+ in "'{" <> T.intercalate "," allFields <> "}'"++-- | Format a field as a JSON key-value pair+formatFieldExample :: IR -> FieldDef -> Text+formatFieldExample ir field =+ "\\\"" <> fdName field <> "\\\":" <> simpleExample (fdType field)+ where+ simpleExample :: TypeRef -> Text+ simpleExample = \case+ RefPrimitive "string" _ -> "\\\"value\\\""+ RefPrimitive "integer" _ -> "42"+ RefPrimitive "boolean" _ -> "true"+ RefPrimitive "number" _ -> "3.14"+ RefNamed qn -> case lookupTypeDef ir qn of+ Just td -> case tdKind td of+ KindStringEnum (v:_) -> "\\\"" <> v <> "\\\""+ _ -> "{}"+ Nothing -> "{}"+ _ -> "{}"++-- | Generate a CLI parameter flag with example value+generateExampleParam :: IR -> ParamDef -> Text+generateExampleParam ir param =+ "--" <> pdName param <> " " <> generateExampleValue ir (pdType param)++-- | Look up a type definition in the IR by qualified name+lookupTypeDef :: IR -> QualifiedName -> Maybe TypeDef+lookupTypeDef ir qn =+ Map.lookup (qualifiedNameFull qn) (irTypes ir)
+ src/Synapse/Self/Pattern.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Pattern matching for method filtering+--+-- Supports glob-style patterns with wildcards:+-- - plexus.cone.* - matches all methods in cone+-- - plexus.*.create - matches create methods in all activations+-- - plexus.(cone|arbor).* - regex patterns for complex matching+module Synapse.Self.Pattern+ ( MethodPattern(..)+ , parsePattern+ , matchMethods+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Text.Regex.TDFA ((=~))+import Synapse.IR.Types (MethodDef(..))++-- | A compiled pattern for matching method paths+data MethodPattern = MethodPattern+ { mpRawPattern :: Text -- ^ Original pattern text+ , mpRegex :: Text -- ^ Compiled regex pattern+ }+ deriving stock (Show, Eq)++-- | Parse a pattern string into a MethodPattern+-- Converts glob-style wildcards to regex:+-- * -> [^.]+ (matches any segment)+-- . -> \. (literal dot)+parsePattern :: Text -> Either Text MethodPattern+parsePattern raw = do+ let regex = patternToRegex raw+ Right $ MethodPattern raw regex++-- | Convert a glob-style pattern to a PCRE regex+-- Examples:+-- "plexus.cone.*" -> "^plexus\.cone\.[^.]+$"+-- "plexus.*.create" -> "^plexus\.[^.]+\.create$"+patternToRegex :: Text -> Text+patternToRegex pattern =+ let escaped = T.replace "." "\\." pattern -- Escape dots first+ withWildcards = T.replace "*" "[^.]+" escaped -- Replace * with segment matcher+ in "^" <> withWildcards <> "$" -- Anchor at both ends++-- | Filter methods that match the pattern+matchMethods :: MethodPattern -> [MethodDef] -> [MethodDef]+matchMethods (MethodPattern _ regex) methods =+ filter (\m -> T.unpack (mdFullPath m) =~ T.unpack regex) methods
+ src/Synapse/Self/Template.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | CRUD operations for Mustache templates+--+-- Provides commands to manage the template system:+-- - list: List existing templates (with pattern filtering)+-- - show: Display template content+-- - generate: Generate new templates from IR+-- - delete: Remove templates+-- - reload: Clear template cache and notify backend+module Synapse.Self.Template+ ( handleTemplate+ ) where++import Control.Monad (forM_, when, unless, filterM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.List (sort)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import System.Directory (doesFileExist, getHomeDirectory, removeFile, listDirectory, doesDirectoryExist, createDirectoryIfMissing)+import System.FilePath ((</>), (<.>), takeExtension, dropExtension, splitDirectories, joinPath)++import Synapse.Monad+import Synapse.Self.Pattern (MethodPattern(..), parsePattern, matchMethods)+import qualified Synapse.CLI.Template as CLITemplate+import Synapse.IR.Types (MethodDef(..))+import qualified Data.Map.Strict as Map+import Text.Regex.TDFA ((=~))++-- ============================================================================+-- Main Entry Point+-- ============================================================================++-- | Handle template subcommands+handleTemplate :: [Text] -> [(Text, Text)] -> SynapseM ()+handleTemplate [] _ = do+ -- No subcommand - show help+ liftIO $ TIO.putStr templateHelp++handleTemplate ("list" : rest) params = do+ backend <- asks seBackend+ let patternText = case rest of+ [] -> backend <> ".*.*" -- Default includes backend+ segs -> T.intercalate "." segs+ templateList patternText++handleTemplate ("show" : rest) _ = do+ case rest of+ [] -> throwParse "Missing method path for 'show' command\nUsage: synapse _self template show <namespace.method>"+ segs -> templateShow (T.intercalate "." segs)++handleTemplate ("generate" : rest) params = do+ backend <- asks seBackend+ let patternText = case rest of+ [] -> backend <> ".*.*" -- Default includes backend+ segs -> T.intercalate "." segs+ templateGenerate patternText params++handleTemplate ("delete" : rest) _ = do+ case rest of+ [] -> throwParse "Missing pattern for 'delete' command\nUsage: synapse _self template delete <pattern>"+ segs -> templateDelete (T.intercalate "." segs)++handleTemplate ("reload" : _) _ = do+ templateReload++handleTemplate (cmd : _) _ = do+ throwParse $ "Unknown template subcommand: " <> cmd <> "\n\n" <> templateHelp++-- ============================================================================+-- Template List+-- ============================================================================++templateList :: Text -> SynapseM ()+templateList patternText = do+ backend <- asks seBackend++ -- Parse pattern+ pattern <- case parsePattern patternText of+ Left err -> throwParse err+ Right p -> pure p++ -- Get template base directory+ homeDir <- liftIO getHomeDirectory+ let baseDir = homeDir </> ".config" </> "synapse" </> "templates"++ -- Check if templates directory exists+ exists <- liftIO $ doesDirectoryExist baseDir+ unless exists $ do+ liftIO $ TIO.putStrLn $ "No templates directory found at: " <> T.pack baseDir+ liftIO $ TIO.putStrLn "Generate templates with: synapse --generate-templates"+ return ()++ -- Find all template files+ templateFiles <- liftIO $ findTemplateFiles baseDir++ -- Filter by pattern+ let qualifiedPaths = map (\(ns, m) -> backend <> "." <> ns <> "." <> m) templateFiles+ let matchingPaths = filter (\path -> T.unpack path `matchPattern` pattern) qualifiedPaths+ let matchingFiles = [(ns, m) | ((ns, m), qpath) <- zip templateFiles qualifiedPaths, qpath `elem` matchingPaths]++ -- Display results+ liftIO $ do+ if null matchingFiles+ then TIO.putStrLn $ "No templates match pattern: " <> patternText+ else do+ TIO.putStrLn $ "Found " <> T.pack (show (length matchingFiles)) <> " template(s):\n"+ forM_ (sort matchingFiles) $ \(namespace, method) -> do+ let path = baseDir </> T.unpack namespace </> T.unpack method <.> "mustache"+ TIO.putStrLn $ " " <> backend <> "." <> namespace <> "." <> method+ TIO.putStrLn $ " " <> T.pack path++-- Helper to check if a string matches a pattern+matchPattern :: String -> MethodPattern -> Bool+matchPattern str (MethodPattern _ regex) = str =~ T.unpack regex++-- ============================================================================+-- Template Show+-- ============================================================================++templateShow :: Text -> SynapseM ()+templateShow methodPath = do+ backend <- asks seBackend++ -- Strip backend prefix if present+ let pathWithoutBackend = case T.stripPrefix (backend <> ".") methodPath of+ Just p -> p+ Nothing -> methodPath++ -- Split into namespace.method+ case T.splitOn "." pathWithoutBackend of+ [namespace, method] -> do+ homeDir <- liftIO getHomeDirectory+ let templatePath = homeDir </> ".config" </> "synapse" </> "templates"+ </> T.unpack namespace </> T.unpack method <.> "mustache"++ exists <- liftIO $ doesFileExist templatePath+ if exists+ then do+ content <- liftIO $ TIO.readFile templatePath+ liftIO $ do+ TIO.putStrLn $ "Template: " <> backend <> "." <> namespace <> "." <> method+ TIO.putStrLn $ "Location: " <> T.pack templatePath+ TIO.putStrLn $ T.replicate 60 "━"+ TIO.putStr content+ when (not $ T.null content && T.last content == '\n') $+ TIO.putStrLn ""+ else throwParse $ "Template not found: " <> methodPath <> "\nPath: " <> T.pack templatePath++ _ -> throwParse $ "Invalid method path: " <> methodPath <> "\nExpected format: namespace.method"++-- ============================================================================+-- Template Generate+-- ============================================================================++templateGenerate :: Text -> [(Text, Text)] -> SynapseM ()+templateGenerate patternText params = do+ backend <- asks seBackend+ homeDir <- liftIO getHomeDirectory+ let baseDir = homeDir </> ".config" </> "synapse" </> "templates"++ -- Strip backend prefix if present for IR generation+ let pathWithoutBackend = case T.stripPrefix (backend <> ".") patternText of+ Just p -> p+ Nothing -> patternText++ -- Parse pattern to determine what to generate+ pattern <- case parsePattern patternText of+ Left err -> throwParse err+ Right p -> pure p++ liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."++ -- Use existing CLI.Template generation with callback+ let writeAndLog gt = do+ let fullPath = baseDir </> CLITemplate.gtPath gt+ createDirectoryIfMissing True (baseDir </> T.unpack (CLITemplate.gtNamespace gt))+ TIO.writeFile fullPath (CLITemplate.gtTemplate gt)+ TIO.putStrLn $ " " <> backend <> "." <> CLITemplate.gtNamespace gt <> "." <> CLITemplate.gtMethod gt++ -- Generate all templates (filtering will happen based on path)+ count <- CLITemplate.generateAllTemplatesWithCallback writeAndLog []++ liftIO $ TIO.putStrLn $ "\nGenerated " <> T.pack (show count) <> " template(s)"++-- ============================================================================+-- Template Delete+-- ============================================================================++templateDelete :: Text -> SynapseM ()+templateDelete patternText = do+ backend <- asks seBackend++ -- Parse pattern+ pattern <- case parsePattern patternText of+ Left err -> throwParse err+ Right p -> pure p++ -- Get template base directory+ homeDir <- liftIO getHomeDirectory+ let baseDir = homeDir </> ".config" </> "synapse" </> "templates"++ -- Find all template files+ templateFiles <- liftIO $ findTemplateFiles baseDir++ -- Filter by pattern+ let qualifiedPaths = map (\(ns, m) -> backend <> "." <> ns <> "." <> m) templateFiles+ let matchingPaths = filter (\path -> T.unpack path `matchPattern` pattern) qualifiedPaths+ let matchingFiles = [(ns, m, path) | ((ns, m), qpath) <- zip templateFiles qualifiedPaths, qpath `elem` matchingPaths,+ let path = baseDir </> T.unpack ns </> T.unpack m <.> "mustache"]++ -- Confirm deletion+ liftIO $ do+ if null matchingFiles+ then TIO.putStrLn $ "No templates match pattern: " <> patternText+ else do+ TIO.putStrLn $ "Will delete " <> T.pack (show (length matchingFiles)) <> " template(s):"+ forM_ matchingFiles $ \(ns, m, _) ->+ TIO.putStrLn $ " " <> backend <> "." <> ns <> "." <> m++ -- Delete files+ forM_ matchingFiles $ \(ns, m, path) -> do+ removeFile path+ TIO.putStrLn $ "Deleted: " <> backend <> "." <> ns <> "." <> m++-- ============================================================================+-- Template Reload+-- ============================================================================++templateReload :: SynapseM ()+templateReload = do+ -- Clear local cache (if we had one)+ liftIO $ TIO.putStrLn "Template cache cleared"++ -- TODO: Call backend reload endpoint when available+ -- For now, just notify the user+ liftIO $ TIO.putStrLn "Note: Backend template reload endpoint not yet implemented"++-- ============================================================================+-- Helpers+-- ============================================================================++-- | Find all template files in the templates directory+-- Returns list of (namespace, method) tuples+findTemplateFiles :: FilePath -> IO [(Text, Text)]+findTemplateFiles baseDir = do+ exists <- doesDirectoryExist baseDir+ if not exists+ then return []+ else do+ namespaces <- listDirectory baseDir+ concat <$> mapM findInNamespace namespaces+ where+ findInNamespace :: FilePath -> IO [(Text, Text)]+ findInNamespace namespace = do+ let nsDir = baseDir </> namespace+ isDir <- doesDirectoryExist nsDir+ if not isDir+ then return []+ else do+ files <- listDirectory nsDir+ let templateFiles = filter (\f -> takeExtension f == ".mustache") files+ let methods = map (T.pack . dropExtension) templateFiles+ return [(T.pack namespace, m) | m <- methods]++-- ============================================================================+-- Help Text+-- ============================================================================++templateHelp :: Text+templateHelp = T.unlines+ [ "Template CRUD commands:"+ , ""+ , " synapse _self template list [pattern]"+ , " List existing templates"+ , " Pattern: backend.namespace.method (e.g., 'plexus.cone.*')"+ , " Default: '*.*' (all templates)"+ , ""+ , " synapse _self template show <method>"+ , " Display template content"+ , " Example: synapse _self template show cone.chat"+ , ""+ , " synapse _self template generate [pattern]"+ , " Generate new templates from IR"+ , " Pattern: backend.namespace.method (e.g., 'plexus.cone.*')"+ , " Default: '*.*' (all methods)"+ , ""+ , " synapse _self template delete <pattern>"+ , " Delete templates matching pattern"+ , " Example: synapse _self template delete 'plexus.cone.*'"+ , ""+ , " synapse _self template reload"+ , " Clear template cache and notify backend"+ , ""+ , "Templates are stored in: ~/.config/synapse/templates/"+ , ""+ ]
+ src/Synapse/Transport.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Transport layer for Synapse+--+-- Bridges the low-level Substrate transport to the SynapseM monad.+module Synapse.Transport+ ( -- * Schema Fetching+ fetchSchema+ , fetchSchemaAt+ , fetchMethodSchema++ -- * Method Invocation (collected)+ , invoke+ , invokeRaw++ -- * Method Invocation (streaming)+ , invokeStreaming+ , invokeStreamingWithBidir++ -- * Bidirectional Response+ , sendResponse+ ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Aeson (Value)+import Data.Text (Text)+import qualified Data.Text as T++import Plexus.Client (SubstrateConfig(..))+import qualified Plexus.Transport as ST+import qualified Plexus.Types as PT++import Synapse.Schema.Types+import Synapse.Monad++-- | Fetch the root schema+fetchSchema :: SynapseM PluginSchema+fetchSchema = fetchSchemaAt []++-- | Convert plexus-protocol TransportError to error message+transportErrorToText :: PT.TransportError -> Text+transportErrorToText (PT.ConnectionRefused host port) =+ "Connection refused to " <> host <> ":" <> T.pack (show port)+transportErrorToText (PT.ConnectionTimeout host port) =+ "Connection timeout to " <> host <> ":" <> T.pack (show port)+transportErrorToText (PT.ProtocolError msg) = "Protocol error: " <> msg+transportErrorToText (PT.NetworkError msg) = "Network error: " <> msg++-- | Convert plexus-protocol TransportError to TransportCategory+transportErrorToCategory :: PT.TransportError -> TransportErrorCategory+transportErrorToCategory (PT.ConnectionRefused _ _) = ConnectionRefused+transportErrorToCategory (PT.ConnectionTimeout _ _) = ConnectionTimeout+transportErrorToCategory (PT.ProtocolError _) = ProtocolError+transportErrorToCategory (PT.NetworkError _) = UnknownTransportError++-- | Fetch schema at a specific path+fetchSchemaAt :: Path -> SynapseM PluginSchema+fetchSchemaAt path = do+ cfg <- getConfig+ result <- liftIO $ ST.fetchSchemaAt cfg path+ case result of+ Left err -> throwNav $ FetchError (transportErrorToText err) path+ Right schema -> pure schema++-- | Fetch a specific method's schema (more efficient than full plugin schema)+-- Uses the parameter-based query: plugin.schema with {"method": "name"}+fetchMethodSchema :: Path -> Text -> SynapseM MethodSchema+fetchMethodSchema path methodName = do+ cfg <- getConfig+ result <- liftIO $ ST.fetchMethodSchemaAt cfg path methodName+ case result of+ Left err -> throwNav $ FetchError (transportErrorToText err) path+ Right schema -> pure schema++-- | Invoke a method and return stream items+invoke :: Path -> Text -> Value -> SynapseM [HubStreamItem]+invoke namespacePath method params = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeMethod cfg namespacePath method params+ case result of+ Left transportErr -> do+ -- Build context from typed transport error and environment+ backend <- asks seBackend+ let path = namespacePath ++ [method]+ let ctx = TransportContext+ { tcMessage = transportErrorToText transportErr+ , tcHost = getHost transportErr cfg+ , tcPort = getPort transportErr cfg+ , tcBackend = backend+ , tcPath = path+ , tcCategory = transportErrorToCategory transportErr+ }+ throwTransportWith ctx+ Right items -> pure items+ where+ getHost (PT.ConnectionRefused h _) _ = h+ getHost (PT.ConnectionTimeout h _) _ = h+ getHost _ c = T.pack $ substrateHost c+ getPort (PT.ConnectionRefused _ p) _ = p+ getPort (PT.ConnectionTimeout _ p) _ = p+ getPort _ c = substratePort c++-- | Invoke with raw method path+invokeRaw :: Text -> Value -> SynapseM [HubStreamItem]+invokeRaw method params = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeRaw cfg method params+ case result of+ Left transportErr -> do+ -- Build context from typed transport error and environment+ backend <- asks seBackend+ let path = T.splitOn "." method+ let ctx = TransportContext+ { tcMessage = transportErrorToText transportErr+ , tcHost = getHost transportErr cfg+ , tcPort = getPort transportErr cfg+ , tcBackend = backend+ , tcPath = path+ , tcCategory = transportErrorToCategory transportErr+ }+ throwTransportWith ctx+ Right items -> pure items+ where+ getHost (PT.ConnectionRefused h _) _ = h+ getHost (PT.ConnectionTimeout h _) _ = h+ getHost _ c = T.pack $ substrateHost c+ getPort (PT.ConnectionRefused _ p) _ = p+ getPort (PT.ConnectionTimeout _ p) _ = p+ getPort _ c = substratePort c++-- | Invoke a method with streaming output - calls callback for each item+invokeStreaming :: Path -> Text -> Value -> (HubStreamItem -> IO ()) -> SynapseM ()+invokeStreaming namespacePath method params onItem = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params onItem+ case result of+ Left transportErr -> do+ -- Build context from typed transport error and environment+ backend <- asks seBackend+ let path = namespacePath ++ [method]+ let ctx = TransportContext+ { tcMessage = transportErrorToText transportErr+ , tcHost = getHost transportErr cfg+ , tcPort = getPort transportErr cfg+ , tcBackend = backend+ , tcPath = path+ , tcCategory = transportErrorToCategory transportErr+ }+ throwTransportWith ctx+ Right () -> pure ()+ where+ getHost (PT.ConnectionRefused h _) _ = h+ getHost (PT.ConnectionTimeout h _) _ = h+ getHost _ c = T.pack $ substrateHost c+ getPort (PT.ConnectionRefused _ p) _ = p+ getPort (PT.ConnectionTimeout _ p) _ = p+ getPort _ c = substratePort c++-- | Invoke a method with streaming output and bidirectional request handling+-- When a StreamRequest is received, the bidirectional handler is called and+-- the response is sent back via {backend}.respond (if the handler returns Just).+-- If the handler returns Nothing (BidirRespond mode), no response is sent immediately.+invokeStreamingWithBidir+ :: Path+ -> Text+ -> Value+ -> (HubStreamItem -> IO ()) -- ^ Handler for non-request items+ -> (Text -> PT.Request Value -> IO (Maybe (PT.Response Value))) -- ^ Handler for bidirectional requests+ -> SynapseM ()+invokeStreamingWithBidir namespacePath method params onItem onBidirRequest = do+ cfg <- getConfig+ let wrappedHandler item = case item of+ PT.StreamRequest _ _ reqId reqData _timeout -> do+ -- Handle the bidirectional request+ mResponse <- onBidirRequest reqId reqData+ -- Send the response back via {backend}.respond (if present)+ case mResponse of+ Just response -> do+ _ <- ST.sendBidirectionalResponse cfg reqId response+ pure ()+ Nothing -> pure () -- agent will respond via separate call+ _ -> onItem item+ result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params wrappedHandler+ case result of+ Left transportErr -> do+ backend <- asks seBackend+ let path = namespacePath ++ [method]+ let ctx = TransportContext+ { tcMessage = transportErrorToText transportErr+ , tcHost = getHost transportErr cfg+ , tcPort = getPort transportErr cfg+ , tcBackend = backend+ , tcPath = path+ , tcCategory = transportErrorToCategory transportErr+ }+ throwTransportWith ctx+ Right () -> pure ()+ where+ getHost (PT.ConnectionRefused h _) _ = h+ getHost (PT.ConnectionTimeout h _) _ = h+ getHost _ c = T.pack $ substrateHost c+ getPort (PT.ConnectionRefused _ p) _ = p+ getPort (PT.ConnectionTimeout _ p) _ = p+ getPort _ c = substratePort c++-- | Send a response for a bidirectional request+sendResponse :: Text -> PT.Response Value -> SynapseM ()+sendResponse requestId response = do+ cfg <- getConfig+ result <- liftIO $ ST.sendBidirectionalResponse cfg requestId response+ case result of+ Left transportErr -> do+ backend <- asks seBackend+ let ctx = TransportContext+ { tcMessage = transportErrorToText transportErr+ , tcHost = T.pack $ substrateHost cfg+ , tcPort = substratePort cfg+ , tcBackend = backend+ , tcPath = ["respond"]+ , tcCategory = transportErrorToCategory transportErr+ }+ throwTransportWith ctx+ Right () -> pure ()++-- | Get SubstrateConfig from environment+getConfig :: SynapseM SubstrateConfig+getConfig = do+ host <- asks seHost+ port <- asks sePort+ backend <- asks seBackend+ pure $ SubstrateConfig+ { substrateHost = T.unpack host+ , substratePort = port+ , substratePath = "/"+ , substrateBackend = backend+ }
+ test/CLISpec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++-- | CLI integration tests+--+-- Pattern: args `has` ["expected", "substrings"]+module Main where++import Data.Text (Text)+import qualified Data.Text as T+import System.Process (readProcess)+import Test.Hspec++main :: IO ()+main = hspec $ do++ describe "navigation" $ do+ it "root" $ ["--help"] `has` ["synapse", "plexus"]+ it "plexus" $ ["plexus"] `has` ["echo", "solar", "health"]+ it "echo" $ ["plexus", "echo"] `has` ["echo", "Echo messages back"]+ it "solar" $ ["plexus", "solar"] `has` ["solar", "Solar system model"]+ it "health" $ ["plexus", "health"] `has` ["health", "Check hub health"]+ it "solar earth" $ ["plexus", "solar", "earth"] `has` ["earth", "planet"]+ it "solar earth luna" $ ["plexus", "solar", "earth", "luna"] `has` ["luna", "Moon"]++ describe "method help" $ do+ it "echo once" $ ["plexus", "echo", "once"] `has` ["once", "--message", "required"]+ it "echo echo" $ ["plexus", "echo", "echo"] `has` ["--message", "--count"]+ -- health.check has no required params, so it auto-invokes+ it "health check" $ ["plexus", "health", "check"] `has` ["healthy"]++ describe "invocation" $ do+ it "echo once" $ call ["plexus", "echo", "once"] (msg "test") `has` ["test"]+ it "echo count" $ call ["plexus", "echo", "echo"] (msgN "hi" 2) `has` ["hi", "2"]+ it "health" $ callRaw ["plexus", "health", "check"] "{}" `has` ["healthy"]+ it "solar observe" $ callRaw ["plexus", "solar", "observe"] "{}" `has` ["sol", "planet_count"]+ it "luna info" $ callRaw ["plexus", "solar", "earth", "luna", "info"] "{}" `has` ["luna"]++-- ============================================================================+-- Harness+-- ============================================================================++synapse :: FilePath+synapse = "dist-newstyle/build/aarch64-osx/ghc-9.6.7/plexus-synapse-0.2.0.0/x/synapse/build/synapse/synapse"++-- | Assert synapse output contains all substrings+has :: [String] -> [Text] -> Expectation+has = checkOutput synapse++-- | Generic output checker+checkOutput :: FilePath -> [String] -> [Text] -> Expectation+checkOutput bin args expected = do+ out <- T.pack <$> readProcess bin args ""+ mapM_ (assertContains out) expected++assertContains :: Text -> Text -> Expectation+assertContains haystack needle =+ T.toLower haystack `shouldSatisfy` T.isInfixOf (T.toLower needle)++-- | Build invocation args+call :: [String] -> String -> [String]+call path params = path ++ ["-p", params]++-- | Build invocation args with --raw (skip templates)+-- Note: --raw must come after "plexus" subcommand+callRaw :: [String] -> String -> [String]+callRaw (backend:rest) params = [backend, "--raw"] ++ rest ++ ["-p", params]+callRaw [] params = ["-p", params] -- fallback, shouldn't happen++-- | JSON builders+msg :: String -> String+msg m = "{\"message\":\"" <> m <> "\"}"++msgN :: String -> Int -> String+msgN m n = "{\"message\":\"" <> m <> "\",\"count\":" <> show n <> "}"
+ test/IRSpec.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++-- | Integration tests for IR-based CLI+--+-- Requires a running Hub backend on localhost:4444+--+-- Usage: cabal test ir-test --test-options="<backend> [--port <port>]"+-- Example: cabal test ir-test --test-options="plexus"+-- cabal test ir-test --test-options="plexus --port 5555"+--+-- Tests that for every method in the schema:+-- 1. IR builds successfully+-- 2. All type references resolve+-- 3. Help renders without error+-- 4. Support check returns a valid level+module Main where++import Control.Monad (forM_, unless)+import Data.Aeson (encode, decode)+import qualified Data.ByteString.Lazy as BSL+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import System.Environment (getArgs, withArgs)+import Test.Hspec+import Text.Read (readMaybe)++import Synapse.IR.Types+import Synapse.IR.Builder (buildIR)+import Synapse.CLI.Help (renderMethodHelp, expandType)+import Synapse.CLI.Support (SupportLevel(..), methodSupport)+import Synapse.Monad++main :: IO ()+main = do+ args <- getArgs+ case parseArgs args of+ Nothing -> do+ putStrLn "Usage: ir-test <backend> [--port <port>]"+ putStrLn "Example: cabal test ir-test --test-options=\"plexus\""+ error "Backend argument required"+ Just (backend, port) -> do+ putStrLn $ "Running IR integration tests against localhost:" <> show port <> " (backend: " <> T.unpack backend <> ")"++ -- Initialize environment+ env <- initEnv "127.0.0.1" port backend++ -- Build IR once for all tests+ irResult <- runSynapseM env (buildIR [])++ case irResult of+ Left err -> do+ putStrLn $ "Failed to build IR: " <> show err+ putStrLn "Is the Hub backend running?"+ -- Run minimal spec that reports the failure+ hspec $ describe "IR Integration Tests" $+ it "connects to Hub backend" $+ expectationFailure $ "Could not connect: " <> show err++ Right ir -> withArgs [] $ hspec $ irSpec ir++-- | Parse command-line arguments: <backend> [--port <port>]+parseArgs :: [String] -> Maybe (Text, Int)+parseArgs [] = Nothing+parseArgs (backend:rest) = Just (T.pack backend, parsePort rest)+ where+ parsePort ("--port":p:_) = maybe 4444 id (readMaybe p)+ parsePort _ = 4444++-- | Main spec using pre-built IR+irSpec :: IR -> Spec+irSpec ir = do+ describe "Schema fetching" $ do+ it "builds IR from root" $+ irVersion ir `shouldBe` "2.0"++ it "IR contains methods" $+ Map.size (irMethods ir) `shouldSatisfy` (> 0)++ it "IR contains types" $+ -- Some methods may not have complex types, but we expect at least some+ Map.size (irTypes ir) `shouldSatisfy` (>= 0)++ it "IR contains plugins" $+ Map.size (irPlugins ir) `shouldSatisfy` (> 0)++ describe "Method coverage" $ do+ it "all methods have help text" $+ forM_ (Map.elems $ irMethods ir) $ \method -> do+ let helpText = renderMethodHelp ir method+ T.length helpText `shouldSatisfy` (> 0)+ -- Help should contain method name+ helpText `shouldSatisfy` T.isInfixOf (mdFullPath method)++ it "all type refs resolve" $+ forM_ (Map.elems $ irMethods ir) $ \method -> do+ -- Check each param's type ref+ forM_ (mdParams method) $ \param -> do+ let typeRef = pdType param+ checkTypeRefResolves ir (mdFullPath method) (pdName param) typeRef++ it "all methods have support level" $+ forM_ (Map.elems $ irMethods ir) $ \method -> do+ let support = methodSupport ir method+ -- Support level should be valid (not crash)+ case support of+ FullSupport -> pure ()+ PartialSupport params -> length params `shouldSatisfy` (>= 0)+ NoSupport params -> length params `shouldSatisfy` (> 0)++ describe "QualifiedName serialization" $ do+ it "serializes to structured JSON" $ do+ let qn = QualifiedName { qnNamespace = "cone", qnLocalName = "UUID" }+ let typeRef = RefNamed qn+ let json = encode typeRef+ -- Check that JSON contains expected structure+ let jsonText = decodeUtf8 (BSL.toStrict json)+ jsonText `shouldSatisfy` T.isInfixOf "qnNamespace"+ jsonText `shouldSatisfy` T.isInfixOf "qnLocalName"+ jsonText `shouldSatisfy` T.isInfixOf "cone"+ jsonText `shouldSatisfy` T.isInfixOf "UUID"++ it "serializes QualifiedName with empty namespace" $ do+ let qn = QualifiedName { qnNamespace = "", qnLocalName = "GlobalType" }+ let typeRef = RefNamed qn+ let json = encode typeRef+ let jsonText = decodeUtf8 (BSL.toStrict json)+ jsonText `shouldSatisfy` T.isInfixOf "GlobalType"+ -- Empty namespace should still be present in JSON+ jsonText `shouldSatisfy` T.isInfixOf "qnNamespace"++ it "qualifiedNameFull handles namespaces correctly" $ do+ qualifiedNameFull (QualifiedName "ns" "Type") `shouldBe` "ns.Type"+ qualifiedNameFull (QualifiedName "" "Type") `shouldBe` "Type"++ it "shows expected JSON format" $ do+ -- Test exact JSON format by printing it+ let qn = QualifiedName { qnNamespace = "test", qnLocalName = "MyType" }+ let typeRef = RefNamed qn+ let jsonText = decodeUtf8 (BSL.toStrict (encode typeRef))+ -- Should have "tag" and "contents" for sum type+ jsonText `shouldSatisfy` T.isInfixOf "RefNamed"+ jsonText `shouldSatisfy` T.isInfixOf "contents"++ describe "Specific methods" $ do+ -- Test cone.chat if it exists (has ConeIdentifier discriminated union)+ case Map.lookup "cone.chat" (irMethods ir) of+ Nothing -> it "cone.chat exists (skipped - not found)" pending+ Just method -> do+ it "cone.chat has identifier param" $+ any (\p -> pdName p == "identifier") (mdParams method) `shouldBe` True++ it "cone.chat expands ConeIdentifier" $ do+ let mIdentifier = filter (\p -> pdName p == "identifier") (mdParams method)+ case mIdentifier of+ [] -> expectationFailure "identifier param not found"+ (p:_) -> do+ let expansion = expandType ir "identifier" (pdType p)+ -- Should have expansion for discriminated union+ length expansion `shouldSatisfy` (> 0)+ -- Should contain "Either:" for union types+ any (T.isInfixOf "Either") expansion `shouldBe` True++ -- Test echo.once if it exists (simple params)+ case Map.lookup "echo.once" (irMethods ir) of+ Nothing -> it "echo.once exists (skipped - not found)" pending+ Just method -> do+ it "echo.once has simple params" $+ -- echo.once should have FullSupport since it only has primitives+ case methodSupport ir method of+ FullSupport -> pure ()+ other -> expectationFailure $ "Expected FullSupport, got: " <> show other++ it "echo.once has message param" $+ any (\p -> pdName p == "message") (mdParams method) `shouldBe` True++ describe "Type resolution" $ do+ it "no dangling RefNamed in params" $+ forM_ (Map.elems $ irMethods ir) $ \method ->+ forM_ (mdParams method) $ \param ->+ case getUnresolvedRefs ir (pdType param) of+ [] -> pure ()+ refs -> expectationFailure $ T.unpack $+ "Unresolved refs in " <> mdFullPath method <> "." <> pdName param <>+ ": " <> T.intercalate ", " refs++ it "reports unresolved return type refs (informational)" $ do+ -- Collect all unresolved return type refs+ let unresolvedReturns =+ [ (mdFullPath method, refs)+ | method <- Map.elems (irMethods ir)+ , let refs = getUnresolvedRefs ir (mdReturns method)+ , not (null refs)+ ]+ -- Report them if any, but don't fail - some methods have simple return types+ -- that reference types defined elsewhere (like SchemaResult from health.schema)+ unless (null unresolvedReturns) $ do+ -- Print for informational purposes+ forM_ unresolvedReturns $ \(methodPath, refs) ->+ putStrLn $ " [info] " <> T.unpack methodPath <>+ " has unresolved return refs: " <> T.unpack (T.intercalate ", " refs)+ -- Success - this test is informational only+ pure ()++-- | Check that a TypeRef resolves (if named, exists in irTypes)+checkTypeRefResolves :: IR -> Text -> Text -> TypeRef -> Expectation+checkTypeRefResolves ir methodPath paramName = \case+ RefNamed qn -> do+ let name = qualifiedNameFull qn+ unless (Map.member name (irTypes ir)) $+ expectationFailure $ T.unpack $+ "Unresolved type ref: " <> name <>+ " in " <> methodPath <> "." <> paramName+ RefArray inner -> checkTypeRefResolves ir methodPath paramName inner+ RefOptional inner -> checkTypeRefResolves ir methodPath paramName inner+ RefPrimitive _ _ -> pure ()+ RefAny -> pure ()+ RefUnknown -> pure () -- Unknown is valid (just means schema gap)++-- | Check that no RefNamed references are unresolved+checkNoUnresolvedRefs :: IR -> TypeRef -> Bool+checkNoUnresolvedRefs ir = \case+ RefNamed qn -> Map.member (qualifiedNameFull qn) (irTypes ir)+ RefArray inner -> checkNoUnresolvedRefs ir inner+ RefOptional inner -> checkNoUnresolvedRefs ir inner+ RefPrimitive _ _ -> True+ RefAny -> True+ RefUnknown -> True++-- | Get list of unresolved RefNamed names+getUnresolvedRefs :: IR -> TypeRef -> [Text]+getUnresolvedRefs ir = \case+ RefNamed qn ->+ let name = qualifiedNameFull qn+ in if Map.member name (irTypes ir)+ then []+ else [name]+ RefArray inner -> getUnresolvedRefs ir inner+ RefOptional inner -> getUnresolvedRefs ir inner+ RefPrimitive _ _ -> []+ RefAny -> []+ RefUnknown -> []
+ test/ParseSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Unit tests for CLI parameter parsing+module Main where++import Data.Aeson (Value(..), object)+import qualified Data.Aeson.Key as K+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Vector as V+import Test.Hspec++import Synapse.CLI.Parse+import Synapse.IR.Types++main :: IO ()+main = hspec $ do+ describe "groupByPrefix" $ do+ it "groups dotted keys by prefix" $ do+ let input = [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")]+ let expected = Map.fromList+ [ ("identifier", [("type", "by_name"), ("name", "foo")])+ , ("prompt", [("", "hi")])+ ]+ groupByPrefix input `shouldBe` expected++ it "collects repeated keys for arrays" $ do+ let input = [("tags", "backend"), ("tags", "critical"), ("tags", "urgent")]+ let expected = Map.fromList+ [ ("tags", [("", "backend"), ("", "critical"), ("", "urgent")])+ ]+ groupByPrefix input `shouldBe` expected++ describe "buildParamValue with arrays" $ do+ let emptyIR = IR+ { irVersion = "2.0"+ , irHash = Nothing+ , irTypes = Map.empty+ , irMethods = Map.empty+ , irPlugins = Map.empty+ }++ it "builds string array from repeated values" $ do+ let param = ParamDef+ { pdName = "tags"+ , pdType = RefArray (RefPrimitive "string" Nothing)+ , pdDescription = Nothing+ , pdRequired = True+ , pdDefault = Nothing+ }+ let kvs = [("", "backend"), ("", "critical"), ("", "urgent")]+ let expected = Right $ Array $ V.fromList [String "backend", String "critical", String "urgent"]+ buildParamValue emptyIR param kvs `shouldBe` expected++ it "builds integer array from repeated values" $ do+ let param = ParamDef+ { pdName = "ids"+ , pdType = RefArray (RefPrimitive "integer" Nothing)+ , pdDescription = Nothing+ , pdRequired = True+ , pdDefault = Nothing+ }+ let kvs = [("", "1"), ("", "2"), ("", "3")]+ let expected = Right $ Array $ V.fromList [Number 1, Number 2, Number 3]+ buildParamValue emptyIR param kvs `shouldBe` expected++ it "fails when array has no values" $ do+ let param = ParamDef+ { pdName = "tags"+ , pdType = RefArray (RefPrimitive "string" Nothing)+ , pdDescription = Nothing+ , pdRequired = True+ , pdDefault = Nothing+ }+ let kvs = []+ buildParamValue emptyIR param kvs `shouldSatisfy` isLeft++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft (Right _) = False
+ test/PathNormalizationSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Unit tests for path and parameter normalization+module Main where++import Data.Text (Text)+import qualified Data.Text as T+import Test.Hspec++-- Copy of parsePathAndParams for testing+-- We can't import from Main, so we replicate the logic+parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool)+parsePathAndParams = go [] [] False+ where+ go path params helpReq [] = (reverse path, reverse params, helpReq)+ go path params helpReq (x:xs)+ -- --help flag: mark help requested, don't add as param+ | x == "--help" || x == "-h" =+ go path params True xs+ -- --key value pair (value must not start with --)+ | Just key <- T.stripPrefix "--" x+ , not (T.null key)+ , (val:rest) <- xs+ , not (T.isPrefixOf "--" val) =+ let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case+ in go path ((normalizedKey, val) : params) helpReq rest+ -- --key with no value or next arg is another flag (boolean flag)+ | Just key <- T.stripPrefix "--" x+ , not (T.null key) =+ let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case+ in go path ((normalizedKey, "") : params) helpReq xs+ -- Regular path segment - split on dots to support plexus.cone.chat syntax+ | otherwise =+ let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x+ in go (reverse segments ++ path) params helpReq xs++main :: IO ()+main = hspec $ do+ describe "parsePathAndParams - hyphen normalization" $ do++ it "normalizes hyphens in simple path segments" $ do+ let input = ["changelog", "queue-add", "--help"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["changelog", "queue_add"]+ params `shouldBe` []+ helpReq `shouldBe` True++ it "normalizes hyphens in dot-notation paths" $ do+ let input = ["plexus.cone.queue-add", "--name", "test"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["plexus", "cone", "queue_add"]+ params `shouldBe` [("name", "test")]+ helpReq `shouldBe` False++ it "normalizes hyphens in parameter names" $ do+ let input = ["cone", "create", "--working-dir", "/tmp", "--dry-run"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["cone", "create"]+ params `shouldBe` [("working_dir", "/tmp"), ("dry_run", "")]+ helpReq `shouldBe` False++ it "handles mixed hyphens in path and params" $ do+ let input = ["cone", "queue-list", "--max-count", "10", "--sort-by", "date"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["cone", "queue_list"]+ params `shouldBe` [("max_count", "10"), ("sort_by", "date")]+ helpReq `shouldBe` False++ it "normalizes complex dot-notation with hyphens" $ do+ let input = ["plexus.arbor.tree-create", "--tree-id", "abc-123"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["plexus", "arbor", "tree_create"]+ params `shouldBe` [("tree_id", "abc-123")] -- Value NOT normalized, only key+ helpReq `shouldBe` False++ it "handles underscore paths unchanged" $ do+ let input = ["changelog", "queue_add", "--description", "test"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["changelog", "queue_add"]+ params `shouldBe` [("description", "test")]+ helpReq `shouldBe` False++ it "normalizes nested parameter paths" $ do+ let input = ["cone", "chat", "--identifier.type", "by-name", "--identifier.name", "test"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["cone", "chat"]+ params `shouldBe` [("identifier.type", "by-name"), ("identifier.name", "test")]+ -- Note: parameter suffixes (after .) are NOT normalized in parsePathAndParams+ -- They're handled later in the parsing pipeline+ helpReq `shouldBe` False++ it "normalizes _self template commands" $ do+ let input = ["_self", "template", "show", "cone.queue-add"]+ let (path, params, helpReq) = parsePathAndParams input+ -- Note: "cone.queue-add" splits on dot and normalizes hyphens+ path `shouldBe` ["_self", "template", "show", "cone", "queue_add"]+ params `shouldBe` []+ helpReq `shouldBe` False++ it "handles repeated array parameters with hyphens" $ do+ let input = ["queue-add", "--tags", "backend", "--tags", "critical", "--max-items", "5"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["queue_add"]+ params `shouldBe` [("tags", "backend"), ("tags", "critical"), ("max_items", "5")]+ helpReq `shouldBe` False++ describe "parsePathAndParams - edge cases" $ do++ it "handles empty input" $ do+ let input = []+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` []+ params `shouldBe` []+ helpReq `shouldBe` False++ it "preserves hyphens in parameter values" $ do+ let input = ["cone", "create", "--name", "my-test-cone"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["cone", "create"]+ params `shouldBe` [("name", "my-test-cone")] -- Value preserved+ helpReq `shouldBe` False++ it "handles boolean flags with hyphens" $ do+ let input = ["test", "--verbose", "--dry-run", "--force"]+ let (path, params, helpReq) = parsePathAndParams input+ path `shouldBe` ["test"]+ params `shouldBe` [("verbose", ""), ("dry_run", ""), ("force", "")]+ helpReq `shouldBe` False
+ test/TypeRefJson.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Quick test to see TypeRef JSON serialization+module Main where++import Data.Aeson (encode)+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Text (Text)++import Synapse.IR.Types++main :: IO ()+main = do+ putStrLn "=== TypeRef JSON Serialization Test ==="+ putStrLn ""++ -- Test 1: Simple QualifiedName with namespace+ putStrLn "1. RefNamed with namespace:"+ let qn1 = QualifiedName { qnNamespace = "cone", qnLocalName = "UUID" }+ let ref1 = RefNamed qn1+ putStrLn " Haskell: "+ print ref1+ putStrLn " JSON (compact):"+ BSL.putStrLn (encode ref1)+ putStrLn " JSON (pretty):"+ BSL.putStrLn (encodePretty ref1)+ putStrLn ""++ -- Test 2: Empty namespace+ putStrLn "2. RefNamed with empty namespace:"+ let qn2 = QualifiedName { qnNamespace = "", qnLocalName = "GlobalType" }+ let ref2 = RefNamed qn2+ putStrLn " Haskell: "+ print ref2+ putStrLn " JSON (pretty):"+ BSL.putStrLn (encodePretty ref2)+ putStrLn ""++ -- Test 3: Nested structure+ putStrLn "3. RefOptional (RefArray (RefNamed)):"+ let qn3 = QualifiedName { qnNamespace = "arbor", qnLocalName = "Node" }+ let ref3 = RefOptional (RefArray (RefNamed qn3))+ putStrLn " Haskell: "+ print ref3+ putStrLn " JSON (pretty):"+ BSL.putStrLn (encodePretty ref3)+ putStrLn ""++ -- Test 4: qualifiedNameFull function+ putStrLn "4. qualifiedNameFull examples:"+ putStrLn $ " cone.UUID -> " <> show (qualifiedNameFull qn1)+ putStrLn $ " GlobalType -> " <> show (qualifiedNameFull qn2)+ putStrLn ""++ -- Test 5: FieldDef with QualifiedName+ putStrLn "5. FieldDef with RefNamed:"+ let fd = FieldDef+ { fdName = "tree_id"+ , fdType = RefNamed (QualifiedName "arbor" "UUID")+ , fdDescription = Just "Tree identifier"+ , fdRequired = True+ , fdDefault = Nothing+ }+ putStrLn " JSON (pretty):"+ BSL.putStrLn (encodePretty fd)