packages feed

acolyte-codegen (empty) → 0.1.0.0

raw patch · 13 files changed

+2341/−0 lines, 13 filesdep +acolyte-codegendep +aesondep +base

Dependencies added: acolyte-codegen, aeson, base, bytestring, containers, directory, filepath, hedgehog, text, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for acolyte-codegen++## 0.1.0.0 -- 2026-04-27++* Initial release. Generates acolyte API types from OpenAPI and+  Swagger specs, plus protobuf schema emission and diffing.
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2024-2026, Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from this+   software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ acolyte-codegen.cabal view
@@ -0,0 +1,102 @@+cabal-version:   3.0+name:            acolyte-codegen+version:         0.1.0.0+synopsis:        Generate acolyte API types from OpenAPI/Swagger specs+category:        Web+description:+  Reads an OpenAPI 3.x or Swagger 2.0 JSON spec and generates Haskell+  modules with type-level API definitions, path types, request/response+  data types, and handler stubs. The generated code uses+  acolyte-core types and gets server, client, and OpenAPI+  generation for free.++license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      Josh Burgess <joshburgess.webdev@gmail.com>+homepage:        https://github.com/joshburgess/acolyte+bug-reports:     https://github.com/joshburgess/acolyte/issues+build-type:      Simple++extra-doc-files:+  CHANGELOG.md++library+  exposed-modules:+    Acolyte.Codegen+    Acolyte.Codegen.Parse+    Acolyte.Codegen.IR+    Acolyte.Codegen.Emit+    Acolyte.Codegen.Proto+    Acolyte.Codegen.ProtoDiff+    Acolyte.Codegen.Scaffold++  build-depends:+      base                    >= 4.20 && < 5+    , aeson                   >= 2.1  && < 2.3+    , yaml                    >= 0.11 && < 0.12+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , containers              >= 0.6  && < 0.8+    , filepath                >= 1.4  && < 1.6+    , directory               >= 1.3  && < 1.5++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    DeriveGeneric+    StrictData++  ghc-options: -Wall -funbox-strict-fields++executable acolyte-codegen+  main-is: Main.hs+  hs-source-dirs: app+  default-language: GHC2024+  default-extensions:+    OverloadedStrings++  build-depends:+      base                       >= 4.20 && < 5+    , acolyte-codegen+    , aeson                      >= 2.1  && < 2.3+    , bytestring                 >= 0.11 && < 0.13+    , text                       >= 2.0  && < 2.2++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    StrictData++  ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K"++  build-depends:+      base                       >= 4.20 && < 5+    , acolyte-codegen+    , aeson                      >= 2.1  && < 2.3+    , bytestring                 >= 0.11 && < 0.13+    , text                       >= 2.0  && < 2.2++test-suite properties+  type: exitcode-stdio-1.0+  main-is: Properties.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    StrictData+  ghc-options: -Wall+  build-depends:+      base                       >= 4.20 && < 5+    , acolyte-codegen+    , hedgehog                   >= 1.4  && < 1.8+    , text                       >= 2.0  && < 2.2++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ app/Main.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+-- | CLI for acolyte-codegen.+--+-- Usage:+--   acolyte-codegen generate spec.json [-o output.hs] [-m Module.Name]+--   acolyte-codegen scaffold spec.json --name my-app [--dir .]+module Main (main) where++import System.Environment (getArgs)+import System.Exit (exitFailure)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import Acolyte.Codegen+import Acolyte.Codegen.Scaffold+import Acolyte.Codegen.Proto (parseProtoFile, protoToIR)+import Acolyte.Codegen.ProtoDiff (diffProtos, ProtoDiff (..), DiffSeverity (..))+++main :: IO ()+main = do+  args <- getArgs+  case args of+    ("scaffold" : rest) -> runScaffold rest+    ("generate" : rest) -> runGenerate rest+    ("diff" : rest)     -> runDiff rest+    (f:rest) | not ("-" `isPrefixOf` f) -> runGenerate (f:rest)  -- default to generate+    _ -> usage+++usage :: IO ()+usage = do+  putStrLn "acolyte-codegen — generate API types from OpenAPI/Swagger specs"+  putStrLn ""+  putStrLn "Commands:"+  putStrLn "  generate <spec> [-o output.hs] [-m Module.Name]"+  putStrLn "    Generate a Haskell module from an OpenAPI/Swagger spec."+  putStrLn ""+  putStrLn "  generate --proto <file.proto> [-o output.hs] [-m Module.Name]"+  putStrLn "    Generate a Haskell module from a proto3 service definition."+  putStrLn ""+  putStrLn "  scaffold <spec> --name <project-name> [--dir <output-dir>]"+  putStrLn "    Generate a complete cabal project from a spec."+  putStrLn ""+  putStrLn "  diff <old.proto> <new.proto>"+  putStrLn "    Compare two proto files and report breaking/non-breaking changes."+  putStrLn ""+  putStrLn "Supports JSON, YAML, and proto3. Swagger 2.0 and OpenAPI 3.x auto-detected."+  exitFailure+++runGenerate :: [String] -> IO ()+runGenerate args = case args of+  [] -> usage+  ("--proto":protoFile:rest) -> do+    result <- parseProtoFile protoFile+    case result of+      Left err -> putStrLn ("Error: " ++ show err) >> exitFailure+      Right proto -> do+        let api = protoToIR proto+            moduleName = findFlagT "-m" rest+            cfg = defaultEmitConfig { emitModuleName = moduleName }+            code = emitModule cfg api+        case findFlag "-o" rest of+          Nothing   -> TIO.putStr code+          Just path -> TIO.writeFile path code >> putStrLn ("Generated: " ++ path)+  (inputFile:rest) -> do+    result <- readSpecFile inputFile+    case result of+      Left err -> putStrLn ("Error: " ++ show err) >> exitFailure+      Right api -> do+        let moduleName = findFlagT "-m" rest+            cfg = defaultEmitConfig { emitModuleName = moduleName }+            code = emitModule cfg api+        case findFlag "-o" rest of+          Nothing   -> TIO.putStr code+          Just path -> TIO.writeFile path code >> putStrLn ("Generated: " ++ path)+++runScaffold :: [String] -> IO ()+runScaffold args = case args of+  [] -> usage+  (inputFile:rest) -> do+    result <- readSpecFile inputFile+    case result of+      Left err -> putStrLn ("Error: " ++ show err) >> exitFailure+      Right api -> do+        let name = findFlagT "--name" rest+            dir  = maybe "." id (findFlag "--dir" rest)+            cfg  = ScaffoldConfig+              { scaffoldName = name+              , scaffoldDir  = dir+              }+        scaffoldProject cfg api+++runDiff :: [String] -> IO ()+runDiff (oldFile:newFile:_) = do+  oldResult <- parseProtoFile oldFile+  newResult <- parseProtoFile newFile+  case (oldResult, newResult) of+    (Left err, _) -> putStrLn ("Error parsing old file: " ++ show err) >> exitFailure+    (_, Left err) -> putStrLn ("Error parsing new file: " ++ show err) >> exitFailure+    (Right oldProto, Right newProto) -> do+      let diffs = diffProtos oldProto newProto+      if null diffs+        then putStrLn "No differences found."+        else mapM_ printDiff diffs+  where+    printDiff (ProtoDiff sev desc) =+      TIO.putStrLn $ severityTag sev <> " " <> desc+    severityTag Breaking    = "[BREAKING]"+    severityTag NonBreaking  = "[non-breaking]"+runDiff _ = usage+++-- ===================================================================+-- Arg parsing helpers+-- ===================================================================++findFlag :: String -> [String] -> Maybe String+findFlag _ [] = Nothing+findFlag flag (f:val:_) | f == flag = Just val+findFlag flag (_:xs) = findFlag flag xs++findFlagT :: String -> [String] -> T.Text+findFlagT flag xs = case findFlag flag xs of+  Just v  -> T.pack v+  Nothing -> "Generated.API"++isPrefixOf :: String -> String -> Bool+isPrefixOf [] _ = True+isPrefixOf _ [] = False+isPrefixOf (a:as) (b:bs) = a == b && isPrefixOf as bs
+ src/Acolyte/Codegen.hs view
@@ -0,0 +1,93 @@+-- | @acolyte-codegen@ — generate API types from OpenAPI specs.+--+-- Reads Swagger 2.0 or OpenAPI 3.x JSON and produces Haskell modules+-- with type-level API definitions.+--+-- @+-- import Acolyte.Codegen+--+-- main = do+--   spec <- readSpecFile "openapi.json"+--   case spec of+--     Left err -> putStrLn (show err)+--     Right api -> putStrLn (T.unpack (emitModule defaultEmitConfig api))+-- @+module Acolyte.Codegen+  ( -- * Parsing+    parseSpec+  , ParseError (..)+  , readSpecFile+    -- * Proto parsing+  , parseProtoFile+  , parseProtoText+  , protoToIR+  , generateFromProto+  , ProtoFile (..)+  , ProtoService (..)+  , ProtoRpc (..)+  , ProtoMessage (..)+  , ProtoField (..)+  , ProtoEnum (..)+  , ProtoParseError (..)+    -- * Proto diffing+  , diffProtos+  , ProtoDiff (..)+  , DiffSeverity (..)+    -- * IR+  , ApiIR (..)+  , EndpointIR (..)+  , PathSegmentIR (..)+  , SchemaIR (..)+  , FieldIR (..)+  , HttpMethod (..)+    -- * Code generation+  , emitModule+  , EmitConfig (..)+  , defaultEmitConfig+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Yaml as Yaml+import Data.Text (Text)+import System.FilePath (takeExtension)++import Acolyte.Codegen.IR+import Acolyte.Codegen.Parse+import Acolyte.Codegen.Emit+import Acolyte.Codegen.Proto+import Acolyte.Codegen.ProtoDiff+++-- | Read and parse a spec file. Supports both JSON and YAML.+--+-- File format is detected by extension:+-- * @.json@ → JSON parser+-- * @.yaml@, @.yml@ → YAML parser+-- * anything else → try YAML first (more permissive), fall back to JSON+readSpecFile :: FilePath -> IO (Either ParseError ApiIR)+readSpecFile path = do+  bytes <- BS.readFile path+  let ext = takeExtension path+      mVal = case ext of+        ".json" -> Aeson.decodeStrict' bytes+        ".yaml" -> either (const Nothing) Just (Yaml.decodeEither' bytes)+        ".yml"  -> either (const Nothing) Just (Yaml.decodeEither' bytes)+        _       -> case Yaml.decodeEither' bytes of+                     Right v  -> Just v+                     Left _   -> Aeson.decodeStrict' bytes+  case mVal of+    Nothing  -> pure (Left (InvalidJSON "Failed to decode file (tried JSON and YAML)"))+    Just val -> pure (parseSpec val)+++-- | Generate Haskell code from a .proto file.+generateFromProto :: FilePath -> IO Text+generateFromProto path = do+  result <- parseProtoFile path+  case result of+    Left err -> error (show err)+    Right proto -> do+      let ir = protoToIR proto+      pure (emitModule defaultEmitConfig ir)
+ src/Acolyte/Codegen/Emit.hs view
@@ -0,0 +1,249 @@+-- | Haskell code generation from the API IR.+--+-- Produces a complete Haskell module with:+-- * Path types using GHC.TypeLits+-- * Request/response data types with FromJSON/ToJSON+-- * The API type as a promoted list+-- * Requires Auth on secured endpoints+module Acolyte.Codegen.Emit+  ( emitModule+  , EmitConfig (..)+  , defaultEmitConfig+  ) where++import Data.Char (toUpper, toLower, isAlpha, isAlphaNum)+import Data.List (intercalate, nub)+import Data.Text (Text)+import qualified Data.Text as T++import Acolyte.Codegen.IR+++-- | Configuration for code emission.+data EmitConfig = EmitConfig+  { emitModuleName :: !Text     -- ^ Module name (e.g., "Generated.API")+  , emitHandlerStubs :: !Bool   -- ^ Generate handler stubs?+  } deriving (Show)++-- | Default emit configuration: module name @"Generated.API"@ with handler stubs enabled.+defaultEmitConfig :: EmitConfig+defaultEmitConfig = EmitConfig+  { emitModuleName   = "Generated.API"+  , emitHandlerStubs = True+  }+++-- | Generate a complete Haskell module from an API IR.+emitModule :: EmitConfig -> ApiIR -> Text+emitModule cfg api = T.unlines $ concat+  [ emitHeader cfg api+  , [""]+  , emitImports+  , [""]+  , emitSchemaTypes (apiSchemas api)+  , [""]+  , emitPathTypes (apiEndpoints api)+  , [""]+  , emitApiType (apiEndpoints api)+  , if emitHandlerStubs cfg+    then [""] ++ emitStubs (apiEndpoints api)+    else []+  ]+++-- ===================================================================+-- Header+-- ===================================================================++emitHeader :: EmitConfig -> ApiIR -> [Text]+emitHeader cfg api =+  [ "-- | Generated from: " <> apiTitle api <> " v" <> apiVersion api+  , "--"+  , "-- This module was auto-generated by acolyte-codegen."+  , "-- Edit the OpenAPI spec and re-run the generator to update."+  , "{-# LANGUAGE DataKinds #-}"+  , "{-# LANGUAGE TypeFamilies #-}"+  , "{-# LANGUAGE TypeOperators #-}"+  , "{-# LANGUAGE OverloadedStrings #-}"+  , "{-# LANGUAGE DeriveGeneric #-}"+  , "{-# LANGUAGE DeriveAnyClass #-}"+  , "module " <> emitModuleName cfg <> " where"+  ]+++-- ===================================================================+-- Imports+-- ===================================================================++emitImports :: [Text]+emitImports =+  [ "import Data.Aeson (FromJSON, ToJSON)"+  , "import Data.Text (Text)"+  , "import GHC.Generics (Generic)"+  , "import Acolyte.Core"+  , "import Acolyte.Server (Json, HandlerFn)"+  ]+++-- ===================================================================+-- Schema types (data declarations)+-- ===================================================================++emitSchemaTypes :: [(Text, SchemaIR)] -> [Text]+emitSchemaTypes schemas = concatMap emitSchemaType named+  where+    named = [ (n, s) | (n, s@(SchemaObject _ fields)) <- schemas, not (null fields) ]++emitSchemaType :: (Text, SchemaIR) -> [Text]+emitSchemaType (name, SchemaObject _ fields) =+  [ "data " <> typeName name <> " = " <> typeName name+  , "  { " <> T.intercalate "\n  , " (map emitField fields)+  , "  } deriving (Show, Eq, Generic, FromJSON, ToJSON)"+  , ""+  ]+emitSchemaType _ = []++emitField :: FieldIR -> Text+emitField f =+  fieldAccessor (fieldName f) <> " :: " <> emitSchemaTypeRef (fieldSchema f)++fieldAccessor :: Text -> Text+fieldAccessor name = T.pack (camelCase (T.unpack name))++emitSchemaTypeRef :: SchemaIR -> Text+emitSchemaTypeRef SchemaString     = "Text"+emitSchemaTypeRef SchemaInteger    = "Int"+emitSchemaTypeRef SchemaNumber     = "Double"+emitSchemaTypeRef SchemaBoolean    = "Bool"+emitSchemaTypeRef (SchemaArray s)  = "[" <> emitSchemaTypeRef s <> "]"+emitSchemaTypeRef (SchemaRef name) = typeName name+emitSchemaTypeRef (SchemaObject n _) = typeName n+++-- ===================================================================+-- Path types+-- ===================================================================++emitPathTypes :: [EndpointIR] -> [Text]+emitPathTypes eps = map emitPathType (nub (map pathId eps))+  where+    pathId ep = (pathTypeName (epPath ep), epPath ep)++    emitPathType (name, segments) =+      "type " <> name <> " = '[" <> T.intercalate ", " (map emitSegment segments) <> "]"+++emitSegment :: PathSegmentIR -> Text+emitSegment (LitSegment s)       = "'Lit \"" <> s <> "\""+emitSegment (CaptureSegment _ t) = "'Capture " <> captureType t++captureType :: Text -> Text+captureType "integer" = "Int"+captureType "number"  = "Double"+captureType _         = "Text"+++pathTypeName :: [PathSegmentIR] -> Text+pathTypeName segments = T.pack $ concatMap segName segments ++ "Path"+  where+    segName (LitSegment s)       = pascal (T.unpack s)+    segName (CaptureSegment n _) = "By" ++ pascal (T.unpack n)+++-- ===================================================================+-- API type+-- ===================================================================++emitApiType :: [EndpointIR] -> [Text]+emitApiType [] = ["type API = '[]"]+emitApiType eps =+  [ "type API ="+  , "  '[ " <> T.intercalate "\n   , " (map emitEndpoint eps)+  , "   ]"+  ]++emitEndpoint :: EndpointIR -> Text+emitEndpoint ep =+  let core = emitCoreEndpoint ep+  in if epRequiresAuth ep+     then "Requires Auth (" <> core <> ")"+     else core++emitCoreEndpoint :: EndpointIR -> Text+emitCoreEndpoint ep =+  let pathName = pathTypeName (epPath ep)+      respType = maybe "Text" emitResponseType (epResponseType ep)+  in case epMethod ep of+    GET    -> "Get " <> pathName <> " (Json " <> respType <> ")"+    DELETE -> "Delete " <> pathName <> " (Json " <> respType <> ")"+    POST   -> "Post " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"+    PUT    -> "Put " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"+    PATCH  -> "Patch " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"+    HEAD   -> "Get " <> pathName <> " (Json " <> respType <> ")"+    OPTIONS -> "Get " <> pathName <> " (Json " <> respType <> ")"++emitReqType :: EndpointIR -> Text+emitReqType ep = case epRequestBody ep of+  Just (SchemaRef name) -> "(Json " <> typeName name <> ")"+  Just _                -> "(Json Value)"+  Nothing               -> "(Json Value)"++emitResponseType :: SchemaIR -> Text+emitResponseType (SchemaRef name)   = typeName name+emitResponseType (SchemaArray s)    = "[" <> emitResponseType s <> "]"+emitResponseType SchemaString       = "Text"+emitResponseType SchemaInteger      = "Int"+emitResponseType SchemaNumber       = "Double"+emitResponseType SchemaBoolean      = "Bool"+emitResponseType (SchemaObject n _) = typeName n+++-- ===================================================================+-- Handler stubs+-- ===================================================================++emitStubs :: [EndpointIR] -> [Text]+emitStubs eps =+  [ "-- ====================================================================="+  , "-- Handler stubs (implement these)"+  , "-- ====================================================================="+  , ""+  ] ++ concatMap emitStub eps++emitStub :: EndpointIR -> [Text]+emitStub ep =+  let name = stubName ep+  in [ "-- " <> T.pack (show (epMethod ep)) <> " " <> reconstructPath (epPath ep)+     , name <> " :: HandlerFn"+     , name <> " _parts _body = error \"TODO: implement " <> name <> "\""+     , ""+     ]++stubName :: EndpointIR -> Text+stubName ep = T.pack $ camelCase $+  map toLower (show (epMethod ep)) ++ concatMap segWord (epPath ep)+  where+    segWord (LitSegment s) = pascal (T.unpack s)+    segWord (CaptureSegment n _) = "By" ++ pascal (T.unpack n)++reconstructPath :: [PathSegmentIR] -> Text+reconstructPath segs = "/" <> T.intercalate "/" (map segText segs)+  where+    segText (LitSegment s) = s+    segText (CaptureSegment n _) = "{" <> n <> "}"+++-- ===================================================================+-- String utilities+-- ===================================================================++typeName :: Text -> Text+typeName = T.pack . pascal . T.unpack++pascal :: String -> String+pascal [] = []+pascal (c:cs) = toUpper c : cs++camelCase :: String -> String+camelCase [] = []+camelCase (c:cs) = toLower c : cs
+ src/Acolyte/Codegen/IR.hs view
@@ -0,0 +1,69 @@+-- | Intermediate representation for API specs.+--+-- Both Swagger 2.0 and OpenAPI 3.x parse into this shared IR.+-- The code emitter generates Haskell from IR, not from raw JSON.+module Acolyte.Codegen.IR+  ( -- * API IR+    ApiIR (..)+  , EndpointIR (..)+  , PathSegmentIR (..)+  , SchemaIR (..)+  , FieldIR (..)+  , HttpMethod (..)+  ) where++import Data.Text (Text)+++-- | An API parsed from a spec file.+data ApiIR = ApiIR+  { apiTitle     :: !Text+  , apiVersion   :: !Text+  , apiEndpoints :: ![EndpointIR]+  , apiSchemas   :: ![(Text, SchemaIR)]  -- named schemas+  } deriving (Show)+++-- | A single endpoint.+data EndpointIR = EndpointIR+  { epMethod       :: !HttpMethod+  , epPath         :: ![PathSegmentIR]+  , epOperationId  :: !(Maybe Text)+  , epSummary      :: !(Maybe Text)+  , epRequestBody  :: !(Maybe SchemaIR)+  , epResponseType :: !(Maybe SchemaIR)+  , epStatusCode   :: !Int+  , epRequiresAuth :: !Bool+  } deriving (Show)+++-- | A path segment.+data PathSegmentIR+  = LitSegment !Text+  | CaptureSegment !Text !Text  -- name, type (e.g., "id", "integer")+  deriving (Show, Eq)+++-- | HTTP method.+data HttpMethod = GET | POST | PUT | DELETE | PATCH | HEAD | OPTIONS+  deriving (Show, Eq)+++-- | A schema (type description).+data SchemaIR+  = SchemaString+  | SchemaInteger+  | SchemaNumber+  | SchemaBoolean+  | SchemaArray !SchemaIR+  | SchemaObject !Text ![FieldIR]  -- name, fields+  | SchemaRef !Text                -- reference to a named schema+  deriving (Show)+++-- | A field in an object schema.+data FieldIR = FieldIR+  { fieldName     :: !Text+  , fieldSchema   :: !SchemaIR+  , fieldRequired :: !Bool+  } deriving (Show)
+ src/Acolyte/Codegen/Parse.hs view
@@ -0,0 +1,289 @@+-- | Parse OpenAPI 3.x and Swagger 2.0 specs into the shared IR.+--+-- Auto-detects the version from the "openapi" or "swagger" field.+module Acolyte.Codegen.Parse+  ( parseSpec+  , ParseError (..)+  ) where++import Data.Aeson (Value (..), Object)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import Data.Maybe (fromMaybe, mapMaybe, catMaybes)+import Data.Text (Text)+import qualified Data.Text as T++import Acolyte.Codegen.IR+++-- | Errors that can occur when parsing an OpenAPI or Swagger spec.+data ParseError+  = UnknownVersion !Text+  | MissingField !Text+  | InvalidJSON !Text+  deriving (Show)+++-- | Parse a JSON Value into ApiIR. Auto-detects Swagger 2.0 vs OpenAPI 3.x.+parseSpec :: Value -> Either ParseError ApiIR+parseSpec (Object obj)+  | Just (String v) <- KM.lookup "openapi" obj, "3" `T.isPrefixOf` v =+      parseOpenApi3 obj+  | Just (String v) <- KM.lookup "swagger" obj, "2" `T.isPrefixOf` v =+      parseSwagger2 obj+  | Just (String v) <- KM.lookup "openapi" obj =+      Left (UnknownVersion v)+  | Just (String v) <- KM.lookup "swagger" obj =+      Left (UnknownVersion v)+  | otherwise =+      Left (MissingField "No 'openapi' or 'swagger' version field found")+parseSpec _ = Left (InvalidJSON "Top-level value must be a JSON object")+++-- ===================================================================+-- OpenAPI 3.x parser+-- ===================================================================++parseOpenApi3 :: Object -> Either ParseError ApiIR+parseOpenApi3 obj = do+  let info = getObject "info" obj+      title = fromMaybe "API" (info >>= getString "title")+      version = fromMaybe "0.0.0" (info >>= getString "version")+      paths = fromMaybe KM.empty (getObject "paths" obj >>= Just . id)+      schemasObj = getObject "components" obj+                   >>= getObjectKM "schemas"+      schemas = maybe [] parseSchemas schemasObj+  let endpoints = concatMap (parsePathItem3 (hasSecuritySchemes obj)) (KM.toList paths)+  Right ApiIR+    { apiTitle     = title+    , apiVersion   = version+    , apiEndpoints = endpoints+    , apiSchemas   = schemas+    }+++parsePathItem3 :: Bool -> (Aeson.Key, Value) -> [EndpointIR]+parsePathItem3 hasSecurity (pathKey, Object pathObj) =+  let path = Key.toText pathKey+      segments = parsePath path+  in mapMaybe (\(method, mVal) -> case mVal of+      Just (Object opObj) -> Just (parseOperation3 hasSecurity method segments opObj)+      _ -> Nothing+    )+    [ (GET,     KM.lookup "get" pathObj)+    , (POST,    KM.lookup "post" pathObj)+    , (PUT,     KM.lookup "put" pathObj)+    , (DELETE,  KM.lookup "delete" pathObj)+    , (PATCH,   KM.lookup "patch" pathObj)+    ]+parsePathItem3 _ _ = []+++parseOperation3 :: Bool -> HttpMethod -> [PathSegmentIR] -> Object -> EndpointIR+parseOperation3 hasSecurity method segments opObj =+  let opId = getString "operationId" opObj+      summary = getString "summary" opObj+      reqBody = getObject "requestBody" opObj >>= parseRequestBody3+      respSchema = parseResponseSchema3 opObj+      statusCode = case method of+        POST -> 201+        _    -> 200+      auth = case KM.lookup "security" opObj of+        Just (Array arr) -> not (null arr)+        _ -> hasSecurity  -- inherit global security if no local override+  in EndpointIR method segments opId summary reqBody respSchema statusCode auth+++parseRequestBody3 :: Object -> Maybe SchemaIR+parseRequestBody3 obj = do+  content <- getObjectKM "content" obj+  jsonContent <- getObjectFromKM "application/json" content+  schema <- getObjectKM "schema" jsonContent+  Just (parseSchemaValue (Object (schema)))+++parseResponseSchema3 :: Object -> Maybe SchemaIR+parseResponseSchema3 opObj = do+  responses <- getObjectKM "responses" opObj+  -- Try 200, 201, then default+  resp <- getObjectFromKM "200" responses+      `orElse` getObjectFromKM "201" responses+      `orElse` getObjectFromKM "default" responses+  content <- getObjectKM "content" resp+  jsonContent <- getObjectFromKM "application/json" content+  schema <- getObjectKM "schema" jsonContent+  Just (parseSchemaValue (Object (schema)))+++-- ===================================================================+-- Swagger 2.0 parser+-- ===================================================================++parseSwagger2 :: Object -> Either ParseError ApiIR+parseSwagger2 obj = do+  let info = getObject "info" obj+      title = fromMaybe "API" (info >>= getString "title")+      version = fromMaybe "0.0.0" (info >>= getString "version")+      paths = fromMaybe KM.empty (getObject "paths" obj >>= Just . id)+      defsObj = getObjectKM "definitions" obj+      schemas = maybe [] parseSchemas defsObj+  let hasSec = case KM.lookup "security" obj of+        Just (Array arr) -> not (null arr)+        _ -> False+  let endpoints = concatMap (parsePathItem2 hasSec) (KM.toList paths)+  Right ApiIR+    { apiTitle     = title+    , apiVersion   = version+    , apiEndpoints = endpoints+    , apiSchemas   = schemas+    }+++parsePathItem2 :: Bool -> (Aeson.Key, Value) -> [EndpointIR]+parsePathItem2 hasSec (pathKey, Object pathObj) =+  let path = Key.toText pathKey+      segments = parsePath path+  in mapMaybe (\(method, mVal) -> case mVal of+      Just (Object opObj) -> Just (parseOperation2 hasSec method segments opObj)+      _ -> Nothing+    )+    [ (GET,     KM.lookup "get" pathObj)+    , (POST,    KM.lookup "post" pathObj)+    , (PUT,     KM.lookup "put" pathObj)+    , (DELETE,  KM.lookup "delete" pathObj)+    , (PATCH,   KM.lookup "patch" pathObj)+    ]+parsePathItem2 _ _ = []+++parseOperation2 :: Bool -> HttpMethod -> [PathSegmentIR] -> Object -> EndpointIR+parseOperation2 hasSec method segments opObj =+  let opId = getString "operationId" opObj+      summary = getString "summary" opObj+      reqBody = parseBodyParam2 opObj+      respSchema = parseResponseSchema2 opObj+      statusCode = case method of+        POST -> 201+        _    -> 200+      auth = case KM.lookup "security" opObj of+        Just (Array arr) -> not (null arr)+        _ -> hasSec+  in EndpointIR method segments opId summary reqBody respSchema statusCode auth+++-- In Swagger 2.0, body params are in the parameters array with "in": "body"+parseBodyParam2 :: Object -> Maybe SchemaIR+parseBodyParam2 opObj = case KM.lookup "parameters" opObj of+  Just (Array params) ->+    let bodyParams = [o | Object o <- foldMap (:[]) params+                        , getString "in" o == Just "body"+                        , Just _ <- [KM.lookup "schema" o]]+    in case bodyParams of+      (bp:_) -> case KM.lookup "schema" bp of+        Just schemaVal -> Just (parseSchemaValue schemaVal)+        _ -> Nothing+      _ -> Nothing+  _ -> Nothing+++parseResponseSchema2 :: Object -> Maybe SchemaIR+parseResponseSchema2 opObj = do+  responses <- getObjectKM "responses" opObj+  resp <- getObjectFromKM "200" responses+      `orElse` getObjectFromKM "201" responses+      `orElse` getObjectFromKM "default" responses+  schema <- getObjectKM "schema" resp+  Just (parseSchemaValue (Object (schema)))+++-- ===================================================================+-- Shared: path parsing+-- ===================================================================++-- | Parse "/users/{id}/posts" into [LitSegment "users", CaptureSegment "id" "string", LitSegment "posts"]+parsePath :: Text -> [PathSegmentIR]+parsePath path =+  let segments = filter (not . T.null) (T.splitOn "/" path)+  in map parseSegment segments++parseSegment :: Text -> PathSegmentIR+parseSegment seg+  | Just ('{', inner) <- T.uncons seg+  , not (T.null inner)+  , T.last inner == '}' =+      let name = T.init inner+      in CaptureSegment name "string"+  | otherwise = LitSegment seg+++-- ===================================================================+-- Shared: schema parsing+-- ===================================================================++parseSchemaValue :: Value -> SchemaIR+parseSchemaValue (Object obj)+  | Just ref <- getString "$ref" obj =+      SchemaRef (extractRef ref)+  | Just (String "array") <- KM.lookup "type" obj =+      let items = case KM.lookup "items" obj of+            Just v  -> parseSchemaValue v+            Nothing -> SchemaString+      in SchemaArray items+  | Just (String "integer") <- KM.lookup "type" obj = SchemaInteger+  | Just (String "number")  <- KM.lookup "type" obj = SchemaNumber+  | Just (String "boolean") <- KM.lookup "type" obj = SchemaBoolean+  | Just (String "string")  <- KM.lookup "type" obj = SchemaString+  | Just (String "object") <- KM.lookup "type" obj =+      let props = case KM.lookup "properties" obj of+            Just (Object ps) -> map (\(k, v) -> FieldIR (Key.toText k) (parseSchemaValue v) True) (KM.toList ps)+            _ -> []+      in SchemaObject "Object" props+  | otherwise = SchemaString  -- fallback+parseSchemaValue _ = SchemaString+++parseSchemas :: KM.KeyMap Value -> [(Text, SchemaIR)]+parseSchemas km =+  [ (Key.toText k, parseSchemaValue v) | (k, v) <- KM.toList km ]+++-- | Extract "User" from "#/definitions/User" or "#/components/schemas/User"+extractRef :: Text -> Text+extractRef ref = case reverse (T.splitOn "/" ref) of+  (x:_) -> x+  _     -> ref+++-- ===================================================================+-- Helpers+-- ===================================================================++getObject :: Text -> Object -> Maybe Object+getObject key obj = case KM.lookup (Key.fromText key) obj of+  Just (Object o) -> Just o+  _ -> Nothing++getObjectKM :: Text -> Object -> Maybe (KM.KeyMap Value)+getObjectKM key obj = case KM.lookup (Key.fromText key) obj of+  Just (Object o) -> Just o+  _ -> Nothing++getObjectFromKM :: Text -> KM.KeyMap Value -> Maybe Object+getObjectFromKM key km = case KM.lookup (Key.fromText key) km of+  Just (Object o) -> Just o+  _ -> Nothing++getString :: Text -> Object -> Maybe Text+getString key obj = case KM.lookup (Key.fromText key) obj of+  Just (String s) -> Just s+  _ -> Nothing++hasSecuritySchemes :: Object -> Bool+hasSecuritySchemes obj = case KM.lookup "security" obj of+  Just (Array arr) -> not (null arr)+  _ -> False++orElse :: Maybe a -> Maybe a -> Maybe a+orElse (Just x) _ = Just x+orElse Nothing  y = y
+ src/Acolyte/Codegen/Proto.hs view
@@ -0,0 +1,491 @@+-- | Parse proto3 service definitions into the shared API IR.+--+-- Supports enough proto3 syntax to extract services, RPCs, messages,+-- and enums. Does not follow imports or act as a full protobuf compiler.+module Acolyte.Codegen.Proto+  ( -- * Parsing+    parseProtoFile+  , parseProtoText+    -- * Types+  , ProtoFile (..)+  , ProtoService (..)+  , ProtoRpc (..)+  , ProtoMessage (..)+  , ProtoField (..)+  , ProtoEnum (..)+  , ProtoParseError (..)+    -- * Conversion to IR+  , protoToIR+  ) where++import Data.Char (isAlphaNum, isAlpha, isDigit, isSpace)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import Acolyte.Codegen.IR+++-- ===================================================================+-- Types+-- ===================================================================++-- | Errors that can occur when parsing a proto file.+data ProtoParseError+  = ProtoSyntaxError !Text+  | ProtoUnsupportedSyntax !Text+  deriving (Show)+++-- | A parsed .proto file.+data ProtoFile = ProtoFile+  { protoSyntax   :: !Text        -- ^ "proto3"+  , protoPackage  :: !Text        -- ^ Package name+  , protoServices :: ![ProtoService]+  , protoMessages :: ![ProtoMessage]+  , protoEnums    :: ![ProtoEnum]+  , protoImports  :: ![Text]+  } deriving (Show)+++-- | A service definition.+data ProtoService = ProtoService+  { psName :: !Text+  , psRpcs :: ![ProtoRpc]+  } deriving (Show)+++-- | An RPC method.+data ProtoRpc = ProtoRpc+  { prName         :: !Text+  , prInputType    :: !Text+  , prOutputType   :: !Text+  , prClientStream :: !Bool+  , prServerStream :: !Bool+  } deriving (Show)+++-- | A message definition.+data ProtoMessage = ProtoMessage+  { pmName   :: !Text+  , pmFields :: ![ProtoField]+  } deriving (Show)+++-- | A field in a message.+data ProtoField = ProtoField+  { pfFieldType   :: !Text+  , pfFieldName   :: !Text+  , pfFieldNumber :: !Int+  , pfRepeated    :: !Bool+  , pfOptional    :: !Bool+  } deriving (Show)+++-- | A basic enum definition.+data ProtoEnum = ProtoEnum+  { peName   :: !Text+  , peValues :: ![(Text, Int)]+  } deriving (Show)+++-- ===================================================================+-- Parsing+-- ===================================================================++-- | Parse a .proto file from disk.+parseProtoFile :: FilePath -> IO (Either ProtoParseError ProtoFile)+parseProtoFile path = do+  content <- TIO.readFile path+  pure (parseProtoText content)+++-- | Parse proto3 text content.+parseProtoText :: Text -> Either ProtoParseError ProtoFile+parseProtoText input =+  let cleaned = stripComments input+      stmts   = splitStatements cleaned+  in buildProtoFile stmts+++-- | Strip // and /* */ comments.+stripComments :: Text -> Text+stripComments = go+  where+    go t+      | T.null t = T.empty+      | Just rest <- T.stripPrefix "//" t =+          let (_, after) = T.breakOn "\n" rest+          in go (T.drop 1 after)  -- skip the \n itself+      | Just rest <- T.stripPrefix "/*" t =+          let (_, after) = T.breakOn "*/" rest+          in go (T.drop 2 after)  -- skip the */+      | otherwise =+          case T.uncons t of+            Just (c, rest) -> T.cons c (go rest)+            Nothing        -> T.empty+++-- | Split on top-level statements, respecting braces.+-- Returns a list of statement strings, where brace-delimited blocks+-- are kept together.+splitStatements :: Text -> [Text]+splitStatements input = go 0 T.empty (T.unpack input)+  where+    go :: Int -> Text -> String -> [Text]+    go _ acc [] =+      let s = T.strip acc+      in [s | not (T.null s)]+    go depth acc ('{':cs) =+      go (depth + 1) (T.snoc acc '{') cs+    go depth acc ('}':cs) =+      let newDepth = max 0 (depth - 1)+          acc' = T.snoc acc '}'+      in if newDepth == 0+         then let s = T.strip acc'+              in [s | not (T.null s)] ++ go 0 T.empty cs+         else go newDepth acc' cs+    go 0 acc (';':cs) =+      let s = T.strip acc+      in [s | not (T.null s)] ++ go 0 T.empty cs+    go depth acc (c:cs) =+      go depth (T.snoc acc c) cs+++-- | Build a ProtoFile from parsed top-level statements.+buildProtoFile :: [Text] -> Either ProtoParseError ProtoFile+buildProtoFile stmts =+  let syntax   = findSyntax stmts+      package  = findPackage stmts+      imports  = findImports stmts+      services = findServices stmts+      messages = findMessages stmts+      enums    = findEnums stmts+  in case syntax of+    Just s | s /= "proto3" -> Left (ProtoUnsupportedSyntax s)+    _ -> Right ProtoFile+      { protoSyntax   = maybe "proto3" id syntax+      , protoPackage  = maybe "" id package+      , protoServices = services+      , protoMessages = messages+      , protoEnums    = enums+      , protoImports  = imports+      }+++-- | Extract syntax value.+findSyntax :: [Text] -> Maybe Text+findSyntax [] = Nothing+findSyntax (s:ss)+  | "syntax" `T.isPrefixOf` T.stripStart s =+      Just (extractQuoted s)+  | otherwise = findSyntax ss+++-- | Extract package name.+findPackage :: [Text] -> Maybe Text+findPackage [] = Nothing+findPackage (s:ss)+  | "package" `T.isPrefixOf` T.stripStart s =+      let ws = T.words (T.stripStart s)+      in case ws of+        (_:name:_) -> Just (T.strip name)+        _ -> findPackage ss+  | otherwise = findPackage ss+++-- | Extract import paths.+findImports :: [Text] -> [Text]+findImports = map extractQuoted . filter (\s -> "import" `T.isPrefixOf` T.stripStart s)+++-- | Extract quoted string from a statement like: syntax = "proto3"+extractQuoted :: Text -> Text+extractQuoted t =+  let afterQuote = T.drop 1 (snd (T.breakOn "\"" t))+      value = fst (T.breakOn "\"" afterQuote)+  in value+++-- | Parse all service blocks.+findServices :: [Text] -> [ProtoService]+findServices [] = []+findServices (s:ss)+  | isServiceBlock s = parseService s : findServices ss+  | otherwise = findServices ss+++isServiceBlock :: Text -> Bool+isServiceBlock t =+  let stripped = T.stripStart t+  in "service " `T.isPrefixOf` stripped && T.isInfixOf "{" t+++parseService :: Text -> ProtoService+parseService t =+  let stripped = T.stripStart t+      afterKeyword = T.drop 8 stripped  -- drop "service "+      (name, rest) = T.break (\c -> c == '{' || isSpace c) (T.stripStart afterKeyword)+      body = extractBraceBody rest+      rpcs = parseRpcs body+  in ProtoService (T.strip name) rpcs+++-- | Extract content between first { and last }.+extractBraceBody :: Text -> Text+extractBraceBody t =+  let afterOpen = T.drop 1 (snd (T.breakOn "{" t))+      -- Find last }+      reversed = T.reverse afterOpen+      afterClose = T.drop 1 (snd (T.breakOn "}" reversed))+  in T.reverse afterClose+++-- | Parse rpc statements from a service body.+parseRpcs :: Text -> [ProtoRpc]+parseRpcs body =+  let -- Split on "rpc " to find each rpc declaration+      parts = T.splitOn "rpc " body+  in [ rpc | p <- drop 1 parts, let rpc = parseRpc p ]+++parseRpc :: Text -> ProtoRpc+parseRpc t =+  let -- Format: MethodName (Input) returns (Output) [;{}]+      stripped = T.stripStart t+      (name, rest1) = T.break (\c -> c == '(' || isSpace c) stripped+      -- Find input type in parens+      (clientStream, inputType) = extractParenType rest1+      -- Find "returns"+      afterReturns = T.drop 1 (snd (T.breakOn "returns" rest1))+      rest2 = T.drop 6 afterReturns  -- drop "eturns" (we dropped "r" with breakOn)+      (serverStream, outputType) = extractParenType (T.stripStart rest2)+  in ProtoRpc+    { prName         = T.strip name+    , prInputType    = inputType+    , prOutputType   = outputType+    , prClientStream = clientStream+    , prServerStream = serverStream+    }+++-- | Extract type from parens, detecting "stream" keyword.+-- Input: "(stream Foo)" or "(Foo)"+-- Returns: (isStream, typeName)+extractParenType :: Text -> (Bool, Text)+extractParenType t =+  let afterOpen = T.drop 1 (snd (T.breakOn "(" t))+      inner = T.strip (fst (T.breakOn ")" afterOpen))+  in if "stream " `T.isPrefixOf` inner+     then (True, T.strip (T.drop 7 inner))+     else (False, inner)+++-- | Parse all message blocks.+findMessages :: [Text] -> [ProtoMessage]+findMessages [] = []+findMessages (s:ss)+  | isMessageBlock s = parseMessage s : findMessages ss+  | otherwise = findMessages ss+++isMessageBlock :: Text -> Bool+isMessageBlock t =+  let stripped = T.stripStart t+  in "message " `T.isPrefixOf` stripped && T.isInfixOf "{" t+++parseMessage :: Text -> ProtoMessage+parseMessage t =+  let stripped = T.stripStart t+      afterKeyword = T.drop 8 stripped  -- drop "message "+      (name, rest) = T.break (\c -> c == '{' || isSpace c) (T.stripStart afterKeyword)+      body = extractBraceBody rest+      fields = parseFields body+  in ProtoMessage (T.strip name) fields+++-- | Parse fields from a message body.+parseFields :: Text -> [ProtoField]+parseFields body =+  let lines_ = filter (not . T.null) $ map T.strip $ T.splitOn ";" body+      -- Filter out nested messages, enums, reserved, option statements, oneof blocks+      fieldLines = filter isFieldLine lines_+  in map parseField fieldLines+++isFieldLine :: Text -> Bool+isFieldLine t =+  let stripped = T.stripStart t+  in not (T.null stripped)+     && not ("message " `T.isPrefixOf` stripped)+     && not ("enum " `T.isPrefixOf` stripped)+     && not ("reserved " `T.isPrefixOf` stripped)+     && not ("option " `T.isPrefixOf` stripped)+     && not ("oneof " `T.isPrefixOf` stripped)+     && not ("{" `T.isPrefixOf` stripped)+     && not ("}" `T.isPrefixOf` stripped)+     && T.any isDigit stripped  -- must have a field number+     && T.any (== '=') stripped+++parseField :: Text -> ProtoField+parseField t =+  let ws = T.words (T.stripStart t)+  in case ws of+    ("repeated":typ:name:_:"=":numStr:_) ->+      ProtoField typ (cleanName name) (readInt numStr) True False+    ("repeated":typ:name:"=":numStr:_) ->+      ProtoField typ (cleanName name) (readInt numStr) True False+    ("optional":typ:name:_:"=":numStr:_) ->+      ProtoField typ (cleanName name) (readInt numStr) False True+    ("optional":typ:name:"=":numStr:_) ->+      ProtoField typ (cleanName name) (readInt numStr) False True+    (typ:name:"=":numStr:_) ->+      ProtoField typ (cleanName name) (readInt numStr) False False+    -- Handle "type name = num" without spaces around =+    (typ:nameEq:_) | T.isInfixOf "=" nameEq ->+      let (name, rest') = T.break (== '=') nameEq+          numStr = T.strip (T.drop 1 rest')+      in ProtoField typ (cleanName name) (readInt numStr) False False+    _ -> ProtoField "string" "unknown" 0 False False+++cleanName :: Text -> Text+cleanName = T.filter (\c -> isAlphaNum c || c == '_')+++readInt :: Text -> Int+readInt t =+  let digits = T.takeWhile isDigit (T.filter (\c -> isDigit c || c == '-') t)+  in if T.null digits then 0 else read (T.unpack digits)+++-- | Parse all enum blocks.+findEnums :: [Text] -> [ProtoEnum]+findEnums [] = []+findEnums (s:ss)+  | isEnumBlock s = parseEnum s : findEnums ss+  | otherwise = findEnums ss+++isEnumBlock :: Text -> Bool+isEnumBlock t =+  let stripped = T.stripStart t+  in "enum " `T.isPrefixOf` stripped && T.isInfixOf "{" t+++parseEnum :: Text -> ProtoEnum+parseEnum t =+  let stripped = T.stripStart t+      afterKeyword = T.drop 5 stripped  -- drop "enum "+      (name, rest) = T.break (\c -> c == '{' || isSpace c) (T.stripStart afterKeyword)+      body = extractBraceBody rest+      values = parseEnumValues body+  in ProtoEnum (T.strip name) values+++parseEnumValues :: Text -> [(Text, Int)]+parseEnumValues body =+  let lines_ = filter (not . T.null) $ map T.strip $ T.splitOn ";" body+      valLines = filter (\l -> T.any (== '=') l && not ("option " `T.isPrefixOf` l)) lines_+  in map parseEnumValue valLines+++parseEnumValue :: Text -> (Text, Int)+parseEnumValue t =+  let ws = T.words (T.stripStart t)+  in case ws of+    (name:"=":numStr:_) -> (name, readInt numStr)+    _ -> ("UNKNOWN", 0)+++-- ===================================================================+-- Conversion to IR+-- ===================================================================++-- | Convert a parsed proto file to the shared API IR.+protoToIR :: ProtoFile -> ApiIR+protoToIR pf = ApiIR+  { apiTitle     = if T.null (protoPackage pf)+                   then "Proto API"+                   else protoPackage pf+  , apiVersion   = "0.0.0"+  , apiEndpoints = concatMap serviceEndpoints (protoServices pf)+  , apiSchemas   = map messageToSchema (protoMessages pf)+                ++ map enumToSchema (protoEnums pf)+  }+++-- | Convert a service's RPCs to endpoints.+-- gRPC uses POST for all RPCs, with path /ServiceName/MethodName.+serviceEndpoints :: ProtoService -> [EndpointIR]+serviceEndpoints svc = map (rpcToEndpoint (psName svc)) (psRpcs svc)+++rpcToEndpoint :: Text -> ProtoRpc -> EndpointIR+rpcToEndpoint serviceName rpc = EndpointIR+  { epMethod       = POST+  , epPath         = [LitSegment serviceName, LitSegment (prName rpc)]+  , epOperationId  = Just (prName rpc)+  , epSummary      = Nothing+  , epRequestBody  = if isEmptyType (prInputType rpc)+                     then Nothing+                     else Just (SchemaRef (prInputType rpc))+  , epResponseType = if isEmptyType (prOutputType rpc)+                     then Nothing+                     else Just (SchemaRef (prOutputType rpc))+  , epStatusCode   = 200+  , epRequiresAuth = False+  }+++-- | Check if a type represents "no data" (google.protobuf.Empty).+isEmptyType :: Text -> Bool+isEmptyType t = t == "google.protobuf.Empty" || t == "Empty"+++-- | Convert a proto message to a named schema.+messageToSchema :: ProtoMessage -> (Text, SchemaIR)+messageToSchema msg =+  ( pmName msg+  , SchemaObject (pmName msg) (map fieldToFieldIR (pmFields msg))+  )+++fieldToFieldIR :: ProtoField -> FieldIR+fieldToFieldIR pf =+  let baseSchema = protoTypeToSchema (pfFieldType pf)+      schema = if pfRepeated pf+               then SchemaArray baseSchema+               else baseSchema+  in FieldIR+    { fieldName     = pfFieldName pf+    , fieldSchema   = schema+    , fieldRequired = not (pfOptional pf)+    }+++-- | Map proto types to schema IR types.+protoTypeToSchema :: Text -> SchemaIR+protoTypeToSchema "string"   = SchemaString+protoTypeToSchema "bytes"    = SchemaString+protoTypeToSchema "bool"     = SchemaBoolean+protoTypeToSchema "int32"    = SchemaInteger+protoTypeToSchema "int64"    = SchemaInteger+protoTypeToSchema "uint32"   = SchemaInteger+protoTypeToSchema "uint64"   = SchemaInteger+protoTypeToSchema "sint32"   = SchemaInteger+protoTypeToSchema "sint64"   = SchemaInteger+protoTypeToSchema "fixed32"  = SchemaInteger+protoTypeToSchema "fixed64"  = SchemaInteger+protoTypeToSchema "sfixed32" = SchemaInteger+protoTypeToSchema "sfixed64" = SchemaInteger+protoTypeToSchema "float"    = SchemaNumber+protoTypeToSchema "double"   = SchemaNumber+protoTypeToSchema name       = SchemaRef name  -- message reference+++-- | Convert an enum to a schema (represented as a string with known values).+enumToSchema :: ProtoEnum -> (Text, SchemaIR)+enumToSchema e = (peName e, SchemaString)
+ src/Acolyte/Codegen/ProtoDiff.hs view
@@ -0,0 +1,157 @@+-- | Compare two proto files and report breaking/non-breaking changes.+--+-- Useful for CI pipelines that need to detect backwards-incompatible+-- changes in .proto definitions before deployment.+module Acolyte.Codegen.ProtoDiff+  ( diffProtos+  , ProtoDiff (..)+  , DiffSeverity (..)+  ) where++import Data.Text (Text)+import qualified Data.Text as T++import Acolyte.Codegen.Proto+++-- | Severity of a proto change.+data DiffSeverity+  = Breaking     -- ^ Backwards-incompatible change+  | NonBreaking  -- ^ Safe addition+  deriving (Show, Eq)+++-- | A single difference between two proto files.+data ProtoDiff = ProtoDiff+  { pdSeverity    :: !DiffSeverity+  , pdDescription :: !Text+  } deriving (Show, Eq)+++-- | Compare two proto files and report all differences.+diffProtos :: ProtoFile -> ProtoFile -> [ProtoDiff]+diffProtos old new = concat+  [ diffServices (protoServices old) (protoServices new)+  , diffMessages (protoMessages old) (protoMessages new)+  ]+++-- ===================================================================+-- Service diffing+-- ===================================================================++diffServices :: [ProtoService] -> [ProtoService] -> [ProtoDiff]+diffServices oldSvcs newSvcs = concat+  [ -- Services removed (breaking)+    [ ProtoDiff Breaking ("Service removed: " <> psName s)+    | s <- oldSvcs+    , not (any (\n -> psName n == psName s) newSvcs)+    ]+  , -- Services added (non-breaking)+    [ ProtoDiff NonBreaking ("Service added: " <> psName s)+    | s <- newSvcs+    , not (any (\o -> psName o == psName s) oldSvcs)+    ]+  , -- Services in both: diff their RPCs+    [ d+    | o <- oldSvcs+    , n <- newSvcs+    , psName o == psName n+    , d <- diffRpcs (psName o) (psRpcs o) (psRpcs n)+    ]+  ]+++diffRpcs :: Text -> [ProtoRpc] -> [ProtoRpc] -> [ProtoDiff]+diffRpcs svcName oldRpcs newRpcs = concat+  [ -- RPCs removed (breaking)+    [ ProtoDiff Breaking ("RPC removed: " <> svcName <> "." <> prName r)+    | r <- oldRpcs+    , not (any (\n -> prName n == prName r) newRpcs)+    ]+  , -- RPCs added (non-breaking)+    [ ProtoDiff NonBreaking ("RPC added: " <> svcName <> "." <> prName r)+    | r <- newRpcs+    , not (any (\o -> prName o == prName r) oldRpcs)+    ]+  , -- RPCs in both: check input/output type changes+    [ d+    | o <- oldRpcs+    , n <- newRpcs+    , prName o == prName n+    , d <- diffRpcTypes svcName o n+    ]+  ]+++diffRpcTypes :: Text -> ProtoRpc -> ProtoRpc -> [ProtoDiff]+diffRpcTypes svcName old new = concat+  [ [ ProtoDiff Breaking+      ("RPC input type changed: " <> svcName <> "." <> prName old+        <> " (" <> prInputType old <> " -> " <> prInputType new <> ")")+    | prInputType old /= prInputType new+    ]+  , [ ProtoDiff Breaking+      ("RPC output type changed: " <> svcName <> "." <> prName old+        <> " (" <> prOutputType old <> " -> " <> prOutputType new <> ")")+    | prOutputType old /= prOutputType new+    ]+  ]+++-- ===================================================================+-- Message diffing+-- ===================================================================++diffMessages :: [ProtoMessage] -> [ProtoMessage] -> [ProtoDiff]+diffMessages oldMsgs newMsgs = concat+  [ -- Messages added (non-breaking)+    [ ProtoDiff NonBreaking ("Message added: " <> pmName m)+    | m <- newMsgs+    , not (any (\o -> pmName o == pmName m) oldMsgs)+    ]+  , -- Messages in both: diff their fields+    [ d+    | o <- oldMsgs+    , n <- newMsgs+    , pmName o == pmName n+    , d <- diffFields (pmName o) (pmFields o) (pmFields n)+    ]+  ]+++diffFields :: Text -> [ProtoField] -> [ProtoField] -> [ProtoDiff]+diffFields msgName oldFields newFields = concat+  [ -- Fields removed (breaking)+    [ ProtoDiff Breaking ("Field removed: " <> msgName <> "." <> pfFieldName f)+    | f <- oldFields+    , not (any (\n -> pfFieldName n == pfFieldName f) newFields)+    ]+  , -- Fields added (non-breaking)+    [ ProtoDiff NonBreaking ("Field added: " <> msgName <> "." <> pfFieldName f)+    | f <- newFields+    , not (any (\o -> pfFieldName o == pfFieldName f) oldFields)+    ]+  , -- Fields in both: check type and number changes+    [ d+    | o <- oldFields+    , n <- newFields+    , pfFieldName o == pfFieldName n+    , d <- diffFieldDetails msgName o n+    ]+  ]+++diffFieldDetails :: Text -> ProtoField -> ProtoField -> [ProtoDiff]+diffFieldDetails msgName old new = concat+  [ [ ProtoDiff Breaking+      ("Field type changed: " <> msgName <> "." <> pfFieldName old+        <> " (" <> pfFieldType old <> " -> " <> pfFieldType new <> ")")+    | pfFieldType old /= pfFieldType new+    ]+  , [ ProtoDiff Breaking+      ("Field number changed: " <> msgName <> "." <> pfFieldName old+        <> " (" <> T.pack (show (pfFieldNumber old)) <> " -> " <> T.pack (show (pfFieldNumber new)) <> ")")+    | pfFieldNumber old /= pfFieldNumber new+    ]+  ]
+ src/Acolyte/Codegen/Scaffold.hs view
@@ -0,0 +1,225 @@+-- | Project scaffolding: generate a complete project from an OpenAPI spec.+--+-- Creates a ready-to-build cabal project with:+-- * .cabal file with all dependencies+-- * Generated/API.hs from the spec+-- * Handlers.hs with stubs+-- * Main.hs with server setup and middleware+-- * README.md+module Acolyte.Codegen.Scaffold+  ( scaffoldProject+  , ScaffoldConfig (..)+  , defaultScaffoldConfig+  ) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))++import Acolyte.Codegen.IR+import Acolyte.Codegen.Emit+++-- | Configuration for project scaffolding (project name and output directory).+data ScaffoldConfig = ScaffoldConfig+  { scaffoldName    :: !Text    -- ^ Project/package name+  , scaffoldDir     :: !FilePath -- ^ Output directory+  } deriving (Show)++-- | Default scaffold configuration: project name @"my-api"@ in the current directory.+defaultScaffoldConfig :: ScaffoldConfig+defaultScaffoldConfig = ScaffoldConfig+  { scaffoldName = "my-api"+  , scaffoldDir  = "."+  }+++-- | Generate a complete cabal project from an API IR and scaffold configuration.+scaffoldProject :: ScaffoldConfig -> ApiIR -> IO ()+scaffoldProject cfg api = do+  let name = scaffoldName cfg+      dir  = scaffoldDir cfg </> T.unpack name+      srcDir = dir </> "src"++  createDirectoryIfMissing True srcDir++  -- Generated API module+  let apiCode = emitModule (defaultEmitConfig { emitModuleName = "API" }) api+  TIO.writeFile (srcDir </> "API.hs") apiCode++  -- Handlers module+  TIO.writeFile (srcDir </> "Handlers.hs") (handlersModule api)++  -- Main module+  TIO.writeFile (dir </> "Main.hs") (mainModule name api)++  -- Cabal file+  TIO.writeFile (dir </> (T.unpack name ++ ".cabal")) (cabalFile name)++  -- README+  TIO.writeFile (dir </> "README.md") (readmeFile name api)++  putStrLn $ "Scaffolded project: " ++ dir+  putStrLn $ "  " ++ dir ++ "/" ++ T.unpack name ++ ".cabal"+  putStrLn $ "  " ++ dir ++ "/Main.hs"+  putStrLn $ "  " ++ srcDir ++ "/API.hs"+  putStrLn $ "  " ++ srcDir ++ "/Handlers.hs"+  putStrLn $ "  " ++ dir ++ "/README.md"+  putStrLn ""+  putStrLn $ "Next: cd " ++ dir ++ " && cabal build"+++-- ===================================================================+-- Generated files+-- ===================================================================++handlersModule :: ApiIR -> Text+handlersModule api = T.unlines+  [ "{-# LANGUAGE OverloadedStrings #-}"+  , "-- | Handler implementations."+  , "--"+  , "-- Generated stubs — implement the TODO functions."+  , "module Handlers where"+  , ""+  , "import Acolyte.Server (HandlerFn, intoResponse, mkError)"+  , "import Network.HTTP.Types (status501)"+  , "import Data.Text (Text)"+  , ""+  , T.unlines (map handlerImpl (apiEndpoints api))+  ]++handlerImpl :: EndpointIR -> Text+handlerImpl ep =+  let name = stubNameIR ep+  in T.unlines+    [ "-- | " <> T.pack (show (epMethod ep)) <> " " <> reconstructPathIR (epPath ep)+    , name <> " :: HandlerFn"+    , name <> " _parts _body = pure $ intoResponse (mkError status501 \"not implemented\")"+    ]++stubNameIR :: EndpointIR -> Text+stubNameIR ep = case epOperationId ep of+  Just opId -> camelCaseT opId+  Nothing -> T.pack $ camelCaseS $+    map toLowerC (show (epMethod ep)) ++ concatMap segWordIR (epPath ep)++segWordIR :: PathSegmentIR -> String+segWordIR (LitSegment s) = pascalS (T.unpack s)+segWordIR (CaptureSegment n _) = "By" ++ pascalS (T.unpack n)++reconstructPathIR :: [PathSegmentIR] -> Text+reconstructPathIR segs = "/" <> T.intercalate "/" (map segT segs)+  where+    segT (LitSegment s) = s+    segT (CaptureSegment n _) = "{" <> n <> "}"++camelCaseT :: Text -> Text+camelCaseT = T.pack . camelCaseS . T.unpack++camelCaseS :: String -> String+camelCaseS [] = []+camelCaseS (c:cs) = toLowerC c : cs++pascalS :: String -> String+pascalS [] = []+pascalS (c:cs) = toUpperC c : cs++toLowerC :: Char -> Char+toLowerC c | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)+           | otherwise = c++toUpperC :: Char -> Char+toUpperC c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32)+           | otherwise = c+++mainModule :: Text -> ApiIR -> Text+mainModule name api = T.unlines+  [ "{-# LANGUAGE DataKinds #-}"+  , "{-# LANGUAGE TypeOperators #-}"+  , "{-# LANGUAGE OverloadedStrings #-}"+  , "{-# LANGUAGE AllowAmbiguousTypes #-}"+  , "module Main (main) where"+  , ""+  , "import Spire"+  , "import Spire.Http"+  , "import Spire.Server (runServerBS)"+  , "import Acolyte.Core"+  , "import Acolyte.Server"+  , ""+  , "import API"+  , "import Handlers"+  , ""+  , "main :: IO ()"+  , "main = do"+  , "  putStrLn \"" <> name <> " running on http://localhost:3000\""+  , "  ridLayer <- requestIdLayer"+  , "  let svc = undefined -- TODO: wire handlers to API using mkServer or subRouter"+  , "      app = svc"+  , "            |> ridLayer"+  , "            |> corsLayer permissiveCors"+  , "            |> secureHeadersLayer defaultSecureHeaders"+  , "  runServerBS 3000 app"+  ]+++cabalFile :: Text -> Text+cabalFile name = T.unlines+  [ "cabal-version:   3.0"+  , "name:            " <> name+  , "version:         0.1.0.0"+  , "build-type:      Simple"+  , ""+  , "executable " <> name+  , "  main-is: Main.hs"+  , "  other-modules: API, Handlers"+  , "  hs-source-dirs: ., src"+  , "  default-language: GHC2024"+  , "  default-extensions:"+  , "    DataKinds"+  , "    TypeFamilies"+  , "    TypeOperators"+  , "    OverloadedStrings"+  , "    AllowAmbiguousTypes"+  , "    ScopedTypeVariables"+  , "    DeriveGeneric"+  , "    DeriveAnyClass"+  , ""+  , "  build-depends:"+  , "      base                       >= 4.20 && < 5"+  , "    , acolyte-core"+  , "    , acolyte-server"+  , "    , spire"+  , "    , spire-http"+  , "    , spire-server"+  , "    , http-core"+  , "    , aeson                      >= 2.1  && < 2.3"+  , "    , bytestring                 >= 0.11 && < 0.13"+  , "    , text                       >= 2.0  && < 2.2"+  , "    , http-types                 >= 0.12 && < 0.13"+  ]+++readmeFile :: Text -> ApiIR -> Text+readmeFile name api = T.unlines+  [ "# " <> name+  , ""+  , "Generated from: " <> apiTitle api <> " v" <> apiVersion api+  , ""+  , "## Building"+  , ""+  , "```sh"+  , "cabal build"+  , "cabal run " <> name+  , "```"+  , ""+  , "## Endpoints"+  , ""+  , T.unlines (map epDoc (apiEndpoints api))+  ]++epDoc :: EndpointIR -> Text+epDoc ep = "- `" <> T.pack (show (epMethod ep)) <> " " <> reconstructPathIR (epPath ep) <> "`"+  <> maybe "" (\s -> " — " <> s) (epSummary ep)
+ test/Main.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import qualified Data.Text as T++import Acolyte.Codegen+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- OpenAPI 3.x test spec+-- ===================================================================++openapi3Spec :: Aeson.Value+openapi3Spec = Aeson.object+  [ "openapi" Aeson..= ("3.0.3" :: Text)+  , "info" Aeson..= Aeson.object+      [ "title" Aeson..= ("Pet Store" :: Text)+      , "version" Aeson..= ("1.0.0" :: Text)+      ]+  , "paths" Aeson..= Aeson.object+      [ "/pets" Aeson..= Aeson.object+          [ "get" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("listPets" :: Text)+              , "summary" Aeson..= ("List all pets" :: Text)+              , "responses" Aeson..= Aeson.object+                  [ "200" Aeson..= Aeson.object+                      [ "description" Aeson..= ("A list of pets" :: Text)+                      , "content" Aeson..= Aeson.object+                          [ "application/json" Aeson..= Aeson.object+                              [ "schema" Aeson..= Aeson.object+                                  [ "type" Aeson..= ("array" :: Text)+                                  , "items" Aeson..= Aeson.object+                                      [ "$ref" Aeson..= ("#/components/schemas/Pet" :: Text) ]+                                  ]+                              ]+                          ]+                      ]+                  ]+              ]+          , "post" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("createPet" :: Text)+              , "security" Aeson..= [Aeson.object ["bearerAuth" Aeson..= ([] :: [Text])]]+              , "requestBody" Aeson..= Aeson.object+                  [ "content" Aeson..= Aeson.object+                      [ "application/json" Aeson..= Aeson.object+                          [ "schema" Aeson..= Aeson.object+                              [ "$ref" Aeson..= ("#/components/schemas/Pet" :: Text) ]+                          ]+                      ]+                  ]+              , "responses" Aeson..= Aeson.object+                  [ "201" Aeson..= Aeson.object+                      [ "description" Aeson..= ("Pet created" :: Text) ]+                  ]+              ]+          ]+      , "/pets/{petId}" Aeson..= Aeson.object+          [ "get" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("getPet" :: Text)+              , "responses" Aeson..= Aeson.object+                  [ "200" Aeson..= Aeson.object+                      [ "description" Aeson..= ("A pet" :: Text) ]+                  ]+              ]+          ]+      ]+  , "components" Aeson..= Aeson.object+      [ "schemas" Aeson..= Aeson.object+          [ "Pet" Aeson..= Aeson.object+              [ "type" Aeson..= ("object" :: Text)+              , "properties" Aeson..= Aeson.object+                  [ "id" Aeson..= Aeson.object ["type" Aeson..= ("integer" :: Text)]+                  , "name" Aeson..= Aeson.object ["type" Aeson..= ("string" :: Text)]+                  , "tag" Aeson..= Aeson.object ["type" Aeson..= ("string" :: Text)]+                  ]+              ]+          ]+      ]+  ]+++-- ===================================================================+-- Swagger 2.0 test spec+-- ===================================================================++swagger2Spec :: Aeson.Value+swagger2Spec = Aeson.object+  [ "swagger" Aeson..= ("2.0" :: Text)+  , "info" Aeson..= Aeson.object+      [ "title" Aeson..= ("User Service" :: Text)+      , "version" Aeson..= ("2.0.0" :: Text)+      ]+  , "host" Aeson..= ("localhost:3000" :: Text)+  , "basePath" Aeson..= ("/api" :: Text)+  , "paths" Aeson..= Aeson.object+      [ "/users" Aeson..= Aeson.object+          [ "get" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("listUsers" :: Text)+              , "responses" Aeson..= Aeson.object+                  [ "200" Aeson..= Aeson.object+                      [ "description" Aeson..= ("User list" :: Text)+                      , "schema" Aeson..= Aeson.object+                          [ "type" Aeson..= ("array" :: Text)+                          , "items" Aeson..= Aeson.object+                              [ "$ref" Aeson..= ("#/definitions/User" :: Text) ]+                          ]+                      ]+                  ]+              ]+          ]+      , "/users/{id}" Aeson..= Aeson.object+          [ "get" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("getUser" :: Text)+              , "responses" Aeson..= Aeson.object+                  [ "200" Aeson..= Aeson.object+                      [ "description" Aeson..= ("A user" :: Text) ]+                  ]+              ]+          , "delete" Aeson..= Aeson.object+              [ "operationId" Aeson..= ("deleteUser" :: Text)+              , "security" Aeson..= [Aeson.object ["apiKey" Aeson..= ([] :: [Text])]]+              , "responses" Aeson..= Aeson.object+                  [ "200" Aeson..= Aeson.object+                      [ "description" Aeson..= ("Deleted" :: Text) ]+                  ]+              ]+          ]+      ]+  , "definitions" Aeson..= Aeson.object+      [ "User" Aeson..= Aeson.object+          [ "type" Aeson..= ("object" :: Text)+          , "properties" Aeson..= Aeson.object+              [ "id" Aeson..= Aeson.object ["type" Aeson..= ("integer" :: Text)]+              , "name" Aeson..= Aeson.object ["type" Aeson..= ("string" :: Text)]+              , "email" Aeson..= Aeson.object ["type" Aeson..= ("string" :: Text)]+              ]+          ]+      ]+  ]+++-- ===================================================================+-- Tests+-- ===================================================================++testOpenApi3Parse :: IO ()+testOpenApi3Parse = do+  case parseSpec openapi3Spec of+    Left err -> error $ "FAIL: parse error: " ++ show err+    Right api -> do+      assert "oa3: title" (apiTitle api == "Pet Store")+      assert "oa3: version" (apiVersion api == "1.0.0")+      assert "oa3: 3 endpoints" (length (apiEndpoints api) == 3)+      assert "oa3: 1 schema" (length (apiSchemas api) == 1)++      let eps = apiEndpoints api+      assert "oa3: GET /pets" (epMethod (eps !! 0) == GET)+      assert "oa3: POST /pets has auth" (epRequiresAuth (eps !! 1))+      assert "oa3: POST /pets has request body" (isJust (epRequestBody (eps !! 1)))+      assert "oa3: GET /pets/{petId}" (epMethod (eps !! 2) == GET)+      assert "oa3: capture in path" $+        any isCapture (epPath (eps !! 2))++testSwagger2Parse :: IO ()+testSwagger2Parse = do+  case parseSpec swagger2Spec of+    Left err -> error $ "FAIL: parse error: " ++ show err+    Right api -> do+      assert "sw2: title" (apiTitle api == "User Service")+      assert "sw2: version" (apiVersion api == "2.0.0")+      assert "sw2: 3 endpoints" (length (apiEndpoints api) == 3)+      assert "sw2: 1 schema" (length (apiSchemas api) == 1)++      let eps = apiEndpoints api+      assert "sw2: GET /users" (epMethod (eps !! 0) == GET)+      assert "sw2: GET /users/{id}" (epMethod (eps !! 1) == GET)+      assert "sw2: DELETE /users/{id}" (epMethod (eps !! 2) == DELETE)+      assert "sw2: DELETE has auth" (epRequiresAuth (eps !! 2))++testCodeGen :: IO ()+testCodeGen = do+  case parseSpec openapi3Spec of+    Left err -> error $ "FAIL: parse error: " ++ show err+    Right api -> do+      let code = emitModule defaultEmitConfig api+      assert "codegen: has module declaration" (T.isInfixOf "module Generated.API" code)+      assert "codegen: has DataKinds" (T.isInfixOf "DataKinds" code)+      assert "codegen: has path type" (T.isInfixOf "type Pets" code)+      assert "codegen: has API type" (T.isInfixOf "type API =" code)+      assert "codegen: has Get" (T.isInfixOf "Get " code)+      assert "codegen: has Post" (T.isInfixOf "Post " code)+      assert "codegen: has Requires Auth" (T.isInfixOf "Requires Auth" code)+      assert "codegen: has Pet data type" (T.isInfixOf "data Pet" code)+      assert "codegen: has handler stubs" (T.isInfixOf "TODO: implement" code)++testSwagger2CodeGen :: IO ()+testSwagger2CodeGen = do+  case parseSpec swagger2Spec of+    Left err -> error $ "FAIL: parse error: " ++ show err+    Right api -> do+      let code = emitModule (defaultEmitConfig { emitModuleName = "MyApp.API" }) api+      assert "sw2 codegen: custom module name" (T.isInfixOf "module MyApp.API" code)+      assert "sw2 codegen: has User type" (T.isInfixOf "data User" code)+      assert "sw2 codegen: has Delete" (T.isInfixOf "Delete " code)+      assert "sw2 codegen: has Requires Auth for delete" (T.isInfixOf "Requires Auth" code)+++isCapture :: PathSegmentIR -> Bool+isCapture (CaptureSegment _ _) = True+isCapture _ = False+++-- ===================================================================+-- Proto3 test+-- ===================================================================++testProtoText :: Text+testProtoText = T.unlines+  [ "syntax = \"proto3\";"+  , "package test;"+  , ""+  , "import \"google/protobuf/empty.proto\";"+  , ""+  , "// A greeting service"+  , "service Greeter {"+  , "  rpc SayHello (HelloRequest) returns (HelloReply);"+  , "  rpc SayGoodbye (HelloRequest) returns (google.protobuf.Empty);"+  , "}"+  , ""+  , "/* Request message */"+  , "message HelloRequest {"+  , "  string name = 1;"+  , "  int32 age = 2;"+  , "  repeated string tags = 3;"+  , "  optional string nickname = 4;"+  , "}"+  , ""+  , "message HelloReply {"+  , "  string message = 1;"+  , "}"+  , ""+  , "enum Status {"+  , "  UNKNOWN = 0;"+  , "  ACTIVE = 1;"+  , "  INACTIVE = 2;"+  , "}"+  ]++testProtoParse :: IO ()+testProtoParse = do+  case parseProtoText testProtoText of+    Left err -> error $ "FAIL: proto parse error: " ++ show err+    Right pf -> do+      assert "proto: syntax is proto3" (protoSyntax pf == "proto3")+      assert "proto: package is test" (protoPackage pf == "test")+      assert "proto: 1 import" (length (protoImports pf) == 1)+      assert "proto: 1 service" (length (protoServices pf) == 1)+      assert "proto: 2 messages" (length (protoMessages pf) == 2)+      assert "proto: 1 enum" (length (protoEnums pf) == 1)++      let svc = head (protoServices pf)+      assert "proto: service name is Greeter" (psName svc == "Greeter")+      assert "proto: 2 rpcs" (length (psRpcs svc) == 2)++      let rpc1 = head (psRpcs svc)+      assert "proto: rpc name is SayHello" (prName rpc1 == "SayHello")+      assert "proto: rpc input is HelloRequest" (prInputType rpc1 == "HelloRequest")+      assert "proto: rpc output is HelloReply" (prOutputType rpc1 == "HelloReply")+      assert "proto: no client streaming" (not (prClientStream rpc1))+      assert "proto: no server streaming" (not (prServerStream rpc1))++      let msg1 = head (protoMessages pf)+      assert "proto: message name is HelloRequest" (pmName msg1 == "HelloRequest")+      assert "proto: 4 fields" (length (pmFields msg1) == 4)++      let f1 = head (pmFields msg1)+      assert "proto: field type is string" (pfFieldType f1 == "string")+      assert "proto: field name is name" (pfFieldName f1 == "name")+      assert "proto: field number is 1" (pfFieldNumber f1 == 1)++      let f3 = pmFields msg1 !! 2+      assert "proto: repeated field" (pfRepeated f3)++      let f4 = pmFields msg1 !! 3+      assert "proto: optional field" (pfOptional f4)++      let enum1 = head (protoEnums pf)+      assert "proto: enum name is Status" (peName enum1 == "Status")+      assert "proto: 3 enum values" (length (peValues enum1) == 3)++testProtoToIR :: IO ()+testProtoToIR = do+  case parseProtoText testProtoText of+    Left err -> error $ "FAIL: proto parse error: " ++ show err+    Right pf -> do+      let ir = protoToIR pf+      assert "proto IR: title is package name" (apiTitle ir == "test")+      assert "proto IR: 2 endpoints" (length (apiEndpoints ir) == 2)+      assert "proto IR: 3 schemas (2 messages + 1 enum)" (length (apiSchemas ir) == 3)++      let ep1 = head (apiEndpoints ir)+      assert "proto IR: method is POST" (epMethod ep1 == POST)+      assert "proto IR: path is /Greeter/SayHello"+        (epPath ep1 == [LitSegment "Greeter", LitSegment "SayHello"])+      assert "proto IR: has request body" (isJust (epRequestBody ep1))+      assert "proto IR: has response type" (isJust (epResponseType ep1))++      let ep2 = apiEndpoints ir !! 1+      assert "proto IR: SayGoodbye has no response (Empty)"+        (isNothing (epResponseType ep2))++testProtoCodeGen :: IO ()+testProtoCodeGen = do+  case parseProtoText testProtoText of+    Left err -> error $ "FAIL: proto parse error: " ++ show err+    Right pf -> do+      let ir = protoToIR pf+          code = emitModule defaultEmitConfig ir+      assert "proto codegen: has module declaration" (T.isInfixOf "module Generated.API" code)+      assert "proto codegen: has Post" (T.isInfixOf "Post " code)+      assert "proto codegen: has HelloRequest data type" (T.isInfixOf "data HelloRequest" code)+      assert "proto codegen: has HelloReply data type" (T.isInfixOf "data HelloReply" code)+      assert "proto codegen: has path type with Greeter" (T.isInfixOf "Greeter" code)+      assert "proto codegen: has handler stubs" (T.isInfixOf "TODO: implement" code)+++-- ===================================================================+-- Proto diff tests+-- ===================================================================++-- A modified version: removed SayGoodbye, changed SayHello output,+-- added a new RPC, added a new message, removed a field, changed a field type.+testProtoTextNew :: Text+testProtoTextNew = T.unlines+  [ "syntax = \"proto3\";"+  , "package test;"+  , ""+  , "service Greeter {"+  , "  rpc SayHello (HelloRequest) returns (HelloResponse);"  -- output changed+  , "  rpc SayHi (HelloRequest) returns (HelloReply);"        -- new RPC+  , "}"                                                        -- SayGoodbye removed+  , ""+  , "service Notifier {"                                       -- new service+  , "  rpc Notify (HelloRequest) returns (HelloReply);"+  , "}"+  , ""+  , "message HelloRequest {"+  , "  int32 name = 1;"                                        -- type changed: string -> int32+  , "  int32 age = 2;"+  , "  repeated string tags = 3;"+  , "}"                                                        -- nickname field removed+  , ""+  , "message HelloReply {"+  , "  string message = 1;"+  , "}"+  , ""+  , "message HelloResponse {"                                  -- new message+  , "  string greeting = 1;"+  , "}"+  , ""+  , "enum Status {"+  , "  UNKNOWN = 0;"+  , "  ACTIVE = 1;"+  , "  INACTIVE = 2;"+  , "}"+  ]++testProtoDiff :: IO ()+testProtoDiff = do+  case (parseProtoText testProtoText, parseProtoText testProtoTextNew) of+    (Left err, _) -> error $ "FAIL: old proto parse error: " ++ show err+    (_, Left err) -> error $ "FAIL: new proto parse error: " ++ show err+    (Right oldPf, Right newPf) -> do+      let diffs = diffProtos oldPf newPf++      assert "diff: has diffs" (not (null diffs))++      -- Breaking: SayGoodbye removed+      assert "diff: RPC removed is breaking" $+        any (\d -> T.isInfixOf "SayGoodbye" (pdDescription d) && pdSeverity d == Breaking) diffs++      -- Breaking: SayHello output type changed+      assert "diff: RPC output changed is breaking" $+        any (\d -> T.isInfixOf "output type changed" (pdDescription d) && pdSeverity d == Breaking) diffs++      -- Breaking: HelloRequest.name type changed+      assert "diff: field type changed is breaking" $+        any (\d -> T.isInfixOf "Field type changed" (pdDescription d)+                && T.isInfixOf "name" (pdDescription d)+                && pdSeverity d == Breaking) diffs++      -- Breaking: HelloRequest.nickname removed+      assert "diff: field removed is breaking" $+        any (\d -> T.isInfixOf "Field removed" (pdDescription d)+                && T.isInfixOf "nickname" (pdDescription d)+                && pdSeverity d == Breaking) diffs++      -- Non-breaking: SayHi added+      assert "diff: RPC added is non-breaking" $+        any (\d -> T.isInfixOf "SayHi" (pdDescription d) && pdSeverity d == NonBreaking) diffs++      -- Non-breaking: Notifier service added+      assert "diff: service added is non-breaking" $+        any (\d -> T.isInfixOf "Notifier" (pdDescription d) && pdSeverity d == NonBreaking) diffs++      -- Non-breaking: HelloResponse message added+      assert "diff: message added is non-breaking" $+        any (\d -> T.isInfixOf "HelloResponse" (pdDescription d) && pdSeverity d == NonBreaking) diffs++testProtoDiffIdentical :: IO ()+testProtoDiffIdentical = do+  case parseProtoText testProtoText of+    Left err -> error $ "FAIL: proto parse error: " ++ show err+    Right pf -> do+      let diffs = diffProtos pf pf+      assert "diff identical: no diffs" (null diffs)+++main :: IO ()+main = do+  putStrLn "acolyte-codegen tests:"+  putStrLn ""+  putStrLn "OpenAPI 3.x parsing:"+  testOpenApi3Parse+  putStrLn ""+  putStrLn "Swagger 2.0 parsing:"+  testSwagger2Parse+  putStrLn ""+  putStrLn "Code generation (OpenAPI 3.x):"+  testCodeGen+  putStrLn ""+  putStrLn "Code generation (Swagger 2.0):"+  testSwagger2CodeGen+  putStrLn ""+  putStrLn "Proto3 parsing:"+  testProtoParse+  putStrLn ""+  putStrLn "Proto3 -> IR conversion:"+  testProtoToIR+  putStrLn ""+  putStrLn "Proto3 code generation:"+  testProtoCodeGen+  putStrLn ""+  putStrLn "Proto diff (breaking/non-breaking):"+  testProtoDiff+  putStrLn ""+  putStrLn "Proto diff (identical):"+  testProtoDiffIdentical+  putStrLn ""+  putStrLn "All acolyte-codegen tests passed."
+ test/Properties.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Control.Exception (evaluate, try, SomeException)+import qualified Data.Text as T++import Acolyte.Codegen.Proto+  ( parseProtoText, ProtoFile(..) )+++-- ===================================================================+-- Fuzz: proto parser never crashes on arbitrary input+-- ===================================================================++-- | Feed random unicode text to parseProtoText and assert it returns+-- Left or Right (never throws an uncaught exception).+prop_protoParserDoesNotCrash :: Property+prop_protoParserDoesNotCrash = property $ do+  txt <- forAll $ Gen.text (Range.linear 0 5000) Gen.unicode+  _ <- evalIO $ try @SomeException $ case parseProtoText txt of+    Left _  -> evaluate ()+    Right pf -> evaluate (length (protoServices pf)+      `seq` length (protoMessages pf)+      `seq` length (protoEnums pf)+      `seq` T.length (protoPackage pf)+      `seq` ())+  success+++tests :: IO Bool+tests = checkParallel $$(discover)++main :: IO ()+main = do+  ok <- tests+  if ok then pure () else error "Property tests failed"