Initial commit

.gitignore

@@ -0,0 +1,2 @@
+dist-newstyle/
+.DS_Store

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for openapi3-server-gen
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

src/Tie.hs

@@ -0,0 +1,217 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Tie
+  ( generate,
+    Writer,
+    fileWriter,
+    withTestWriter,
+  )
+where
+
+import qualified Data.HashMap.Strict.InsOrd as InsOrd
+import qualified Data.OpenApi as OpenApi
+import qualified Data.Set as Set
+import Data.Yaml (decodeFileThrow)
+import Prettyprinter (Doc, vsep)
+import Tie.Codegen.Cabal (codegenCabalFile)
+import Tie.Codegen.Imports
+  ( codegenExtraApiModuleDependencies,
+    codegenModuleHeader,
+    codegenResponseDependencies,
+    codegenSchemaDependencies,
+  )
+import Tie.Codegen.Operation
+  ( codegenOperation,
+    codegenOperations,
+  )
+import Tie.Codegen.Response (codegenResponseAuxFile, codegenResponses)
+import Tie.Codegen.Schema (codegenSchema)
+import Tie.Name
+  ( Name,
+    apiHaskellFileName,
+    apiHaskellModuleName,
+    cabalFileName,
+    fromText,
+    responseHaskellFileName,
+    responseHaskellModuleName,
+    toOperationHaskellFileName,
+    toResponseHaskellFileName,
+    toResponseHaskellModuleName,
+    toSchemaHaskellFileName,
+    toSchemaHaskellModuleName,
+  )
+import Tie.Operation
+  ( Operation (..),
+    errors,
+    operationResponseDependencies,
+    operationSchemaDependencies,
+    pathItemsToOperation,
+  )
+import Tie.Resolve (newResolver)
+import Tie.Type
+  ( Named,
+    Type,
+    namedTypeDependencies,
+    schemaToType,
+    transitiveDependencies,
+    typeDependencies,
+  )
+import Tie.Writer (Writer, fileWriter, withTestWriter)
+import Prelude hiding (Type)
+
+-- | Our own version of nubOrd that both nubs and sorts
+nubOrd :: Ord a => [a] -> [a]
+nubOrd = Set.toList . Set.fromList
+
+-- | Read an OpenAPI spec. Throws in case it can not
+-- be read or deserialized.
+readOpenApiSpec ::
+  MonadIO m =>
+  FilePath ->
+  m OpenApi.OpenApi
+readOpenApiSpec filePath =
+  liftIO (decodeFileThrow filePath)
+
+-- | Extracts all the schemas form an 'OpenApi.OpenApi'.
+specSchemas :: OpenApi.OpenApi -> [(Text, OpenApi.Schema)]
+specSchemas =
+  InsOrd.toList . OpenApi._componentsSchemas . OpenApi._openApiComponents
+
+specPaths :: OpenApi.OpenApi -> [(FilePath, OpenApi.PathItem)]
+specPaths = 
+  InsOrd.toList . OpenApi._openApiPaths
+
+specComponents :: OpenApi.OpenApi -> OpenApi.Components
+specComponents = 
+  OpenApi._openApiComponents
+
+generate :: MonadIO m => Writer m -> FilePath -> m ()
+generate write inputFile = do
+  -- TODO make configurable
+  let apiName = "OpenAPI"
+      packageName = "open-api"
+
+  openApi <- readOpenApiSpec inputFile
+
+  -- Helper to resolve components in the spec.
+  let resolver =
+        newResolver
+          (specComponents openApi)
+          (\_ -> error "could not resolve reference")
+
+  -- Extract all the Operations from the spec
+  operations <-
+    pathItemsToOperation
+      resolver
+      errors
+      (specPaths openApi)
+
+  -- Only extract the direct, shallow dependencies. This is used to get a precise
+  -- import list for the api and schema modules.
+  let shallow :: Named Type -> [Name]
+      shallow =
+        namedTypeDependencies
+
+  -- Deeply traverse a type and extracts all dependencies. Used to get a list
+  -- of all the things we have to generate.
+  let transitive :: Named Type -> [Name]
+      transitive =
+        transitiveDependencies
+
+  -- Transitive closure of all the referenced Schemas
+  let allReferencedSchemas :: [Name]
+      allReferencedSchemas =
+        foldMap (operationSchemaDependencies transitive) operations
+
+  -- Walk through all the available Schemas and generate code for the
+  -- referenced ones.
+  for_ (specSchemas openApi) $ \(name, schema) -> do
+    let name' = fromText name
+        path = toSchemaHaskellFileName apiName name'
+        header = codegenModuleHeader (toSchemaHaskellModuleName apiName name')
+    when (name' `elem` allReferencedSchemas) $ do
+      type_ <- schemaToType resolver schema
+      let dependencyCode =
+            codegenSchemaDependencies apiName $
+              nubOrd (typeDependencies shallow type_)
+      output <- codegenSchema name' type_
+      write path $
+        vsep
+          [ header,
+            mempty,
+            dependencyCode,
+            mempty,
+            output
+          ]
+
+  -- For each Operation, generate data types for the responses.
+  for_ operations $ \operation@Operation {name} -> do
+    let path = toResponseHaskellFileName apiName name
+        header = codegenModuleHeader (toResponseHaskellModuleName apiName name)
+
+        dependencyCode =
+          codegenSchemaDependencies apiName $
+            nubOrd (operationSchemaDependencies shallow operation)
+    responsesCode <- codegenResponses resolver operation
+    write path $
+      vsep
+        [ header,
+          mempty,
+          dependencyCode,
+          mempty,
+          responsesCode
+        ]
+
+  -- Generate auxiliary definitions in Response.hs
+  let path = responseHaskellFileName apiName
+      header = codegenModuleHeader (responseHaskellModuleName apiName)
+
+  write path $
+    vsep
+      [ header,
+        mempty,
+        codegenResponseAuxFile
+      ]
+
+  -- Generate a single Api.hs module containing the server for the api
+  operationsCode <- codegenOperations resolver operations
+  let path = apiHaskellFileName apiName
+
+      header =
+        codegenModuleHeader (apiHaskellModuleName apiName)
+      schemaDependencyCode =
+        map
+          (codegenSchemaDependencies apiName . nubOrd . operationSchemaDependencies shallow)
+          operations
+      responseDependencyCode =
+        map
+          (codegenResponseDependencies apiName . nubOrd . operationResponseDependencies)
+          operations
+
+  write path $
+    vsep
+      [ header,
+        mempty,
+        codegenExtraApiModuleDependencies apiName,
+        mempty,
+        vsep schemaDependencyCode,
+        mempty,
+        vsep responseDependencyCode,
+        mempty,
+        operationsCode
+      ]
+
+  -- Last but not least, generate the Cabal file
+  let allReferencedModules :: [Text]
+      allReferencedModules =
+        nubOrd $
+          map (toSchemaHaskellModuleName apiName) allReferencedSchemas
+            ++ foldMap (map (toResponseHaskellModuleName apiName) . operationResponseDependencies) operations
+            ++ [ apiHaskellModuleName apiName,
+                 responseHaskellModuleName apiName
+               ]
+
+      path = cabalFileName packageName
+  write path (codegenCabalFile packageName allReferencedModules)

src/Tie/Codegen/Cabal.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tie.Codegen.Cabal (codegenCabalFile) where
+
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+
+codegenCabalFile :: Text -> [Text] -> Doc ann
+codegenCabalFile packageName exposedModules =
+  PP.vsep
+    [ "cabal-version:" <+> "3.0",
+      "name:" <+> PP.pretty packageName,
+      "version:" <+> "0.1.0.0",
+      "library" <> PP.line
+        <> PP.indent
+          2
+          ( PP.vsep
+              [ "build-depends:" <> PP.line
+                  <> PP.indent
+                    2
+                    ( PP.vsep
+                        [ "," <+> "aeson",
+                          "," <+> "attoparsec",
+                          "," <+> "base",
+                          "," <+> "ghc-prim",
+                          "," <+> "http-api-data",
+                          "," <+> "http-types",
+                          "," <+> "text",
+                          "," <+> "wai"
+                        ]
+                    ),
+                "exposed-modules:" <> PP.line
+                  <> PP.indent
+                    2
+                    ( PP.vsep
+                        (map PP.pretty exposedModules)
+                    )
+              ]
+          )
+    ]

src/Tie/Codegen/Imports.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Codegen.Imports
+  ( codegenModuleHeader,
+    codegenSchemaDependencies,
+    codegenResponseDependencies,
+    codegenExtraApiModuleDependencies,
+  )
+where
+
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+import Tie.Name
+  ( ApiName,
+    Name,
+    responseHaskellModuleName,
+    toResponseHaskellModuleName,
+    toSchemaHaskellModuleName,
+  )
+
+codegenModuleHeader :: Text -> Doc ann
+codegenModuleHeader moduleName =
+  "{-#" <+> "LANGUAGE" <+> "DuplicateRecordFields" <+> "#-}"
+    <> PP.line
+    <> "{-#" <+> "LANGUAGE" <+> "OverloadedStrings" <+> "#-}"
+    <> PP.line
+    <> "{-#" <+> "LANGUAGE" <+> "RankNTypes" <+> "#-}"
+    <> PP.line
+    <> "{-#" <+> "LANGUAGE" <+> "RecordWildCards" <+> "#-}"
+    <> PP.line
+    <> "module" <+> PP.pretty moduleName <+> "where"
+    <> PP.line
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Control.Applicative"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Control.Monad.IO.Class"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Aeson"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Aeson.Parser"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Aeson.Types"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Attoparsec.ByteString"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Maybe"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Data.Text"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "GHC.Types"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Network.HTTP.Types"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Network.Wai"
+    <> PP.line
+    <> "import" <+> "qualified" <+> "Web.HttpApiData"
+
+codegenExtraApiModuleDependencies :: ApiName -> Doc ann
+codegenExtraApiModuleDependencies apiName =
+  "import" <+> PP.pretty (responseHaskellModuleName apiName)
+
+codegenSchemaDependencies :: ApiName -> [Name] -> Doc ann
+codegenSchemaDependencies apiName dependencies =
+  PP.vsep
+    [ "import" <+> PP.pretty (toSchemaHaskellModuleName apiName dependency)
+      | dependency <- dependencies
+    ]
+
+codegenResponseDependencies :: ApiName -> [Name] -> Doc ann
+codegenResponseDependencies apiName dependencies =
+  PP.vsep
+    [ "import" <+> PP.pretty (toResponseHaskellModuleName apiName dependency)
+      | dependency <- dependencies
+    ]

src/Tie/Codegen/Operation.hs

@@ -0,0 +1,253 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Codegen.Operation
+  ( codegenOperation,
+    codegenOperations,
+  )
+where
+
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+import Tie.Codegen.Response (codegenResponses)
+import Tie.Codegen.Schema (codegenFieldType, codegenParamSchema)
+import Tie.Name
+  ( Name,
+    toApiMemberName,
+    toApiResponseTypeName,
+    toParamBinder,
+    toParamName,
+  )
+import Tie.Operation
+  ( Operation (..),
+    Param (..),
+    Path,
+    PathSegment (..),
+    RequestBody (..),
+    Response (..),
+  )
+import Tie.Resolve (Resolver)
+
+codegenOperations :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann)
+codegenOperations resolver operations = do
+  dataApiDecl <- codegenApiType resolver operations
+  operationsCode <- traverse (codegenOperation resolver) operations
+  let apiDecl =
+        -- TODO instead of "application" take name from openapi spec
+        "application" <+> "::" <+> "(" <> "Control.Monad.IO.Class.MonadIO" <+> "m" <> ")" <+> "=>" <+> "(" <> "forall" <+> "a" <+> "." <+> "Network.Wai.Request" <+> "->" <+> "m"
+          <+> "a"
+          <+> "->"
+          <+> "IO"
+          <+> "a" <> ")"
+          <+> "->"
+          <+> "Api"
+          <+> "m"
+          <+> "->"
+          <+> "Network.Wai.Application"
+          <+> "->"
+          <+> "Network.Wai.Application" <> PP.line
+            <> "application"
+          <+> "run"
+          <+> "api"
+          <+> "notFound"
+          <+> "request"
+          <+> "respond"
+          <+> "=" <> PP.line
+            <> PP.indent
+              4
+              ( "case" <+> "Network.Wai.pathInfo" <+> "request" <+> "of" <> PP.line
+                  <> PP.indent
+                    4
+                    ( PP.concatWith
+                        (\x y -> x <> PP.line <> PP.line <> y)
+                        ( operationsCode
+                            ++ [ "_" <+> "->" <> PP.line
+                                   <> PP.indent 4 ("notFound" <+> "request" <+> "respond")
+                               ]
+                        )
+                    )
+                  <> PP.line
+                  <> "where"
+                  <> PP.line
+                  <> PP.indent
+                    4
+                    ( "unsupportedMethod" <+> "_" <+> "=" <> PP.line
+                        <> PP.indent
+                          4
+                          ( "respond" <+> "(" <> "Network.Wai.responseBuilder"
+                              <+> "(" <> "toEnum"
+                              <+> "405" <> ")"
+                              <+> "[]"
+                              <+> "mempty" <> ")"
+                          )
+                        <> PP.line
+                        <> "invalidRequest" <+> "_" <+> "="
+                        <> PP.line
+                        <> PP.indent
+                          4
+                          ( "respond" <+> "(" <> "Network.Wai.responseBuilder"
+                              <+> "(" <> "toEnum"
+                              <+> "401" <> ")"
+                              <+> "[]"
+                              <+> "mempty" <> ")"
+                          )
+                    )
+              )
+
+  pure (dataApiDecl <> PP.line <> PP.line <> apiDecl)
+
+codegenApiType :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann)
+codegenApiType resolver operations = do
+  operationsFieldsCode <- traverse (codegenApiTypeOperation resolver) operations
+  let fieldsCode =
+        PP.concatWith (\x y -> x <> "," <> PP.line <> y) operationsFieldsCode
+
+      dataDecl =
+        "data" <+> "Api" <+> "m" <+> "=" <+> "Api" <+> "{" <> PP.line
+          <> PP.indent 4 fieldsCode
+          <> PP.line
+          <> "}"
+  pure dataDecl
+
+codegenApiTypeOperation :: Monad m => Resolver m -> Operation -> m (PP.Doc ann)
+codegenApiTypeOperation resolver Operation {..} = do
+  paramsCode <-
+    sequence
+      [ codegenParamSchema name schema
+        | VariableSegment Param {name, schema} <- path
+      ]
+  pure $
+    toApiMemberName name <+> "::"
+      <+> PP.concatWith
+        (\x y -> x <+> "->" <+> y)
+        ( paramsCode
+            ++ [ codegenFieldType jsonRequestBodyContent
+                 | Just RequestBody {jsonRequestBodyContent} <- [requestBody]
+               ]
+            ++ ["m" <+> toApiResponseTypeName name]
+        )
+
+codegenOperation :: Monad m => Resolver m -> Operation -> m (PP.Doc ann)
+codegenOperation resolver operation@Operation {..} = do
+  pure $
+    codegenPathGuard path $
+      codegenMethodGuard
+        [ ( method,
+            codegenRequestBodyGuard
+              requestBody
+              ( codegenCallApiMember name path requestBody
+              )
+          )
+        ]
+
+codegenCallApiMember :: Name -> Path -> Maybe RequestBody -> PP.Doc ann
+codegenCallApiMember operationName path requestBody =
+  "run" <+> "request" <+> "$" <+> "do" <> PP.line
+    <> PP.indent
+      4
+      ( "response" <+> "<-" <+> toApiMemberName operationName
+          <+> "api"
+          <+> PP.hsep [toParamBinder name | VariableSegment Param {name} <- path]
+          <+> (maybe mempty (\_ -> "body") requestBody)
+            <> PP.line
+            <> "Control.Monad.IO.Class.liftIO"
+          <+> "(" <> "respond"
+          <+> "(" <> "toResponse"
+          <+> "response" <> ")" <> ")"
+      )
+
+codegenPath :: Monad m => Resolver m -> Path -> m (PP.Doc ann)
+codegenPath resolver path = do
+  segments <- traverse (codegenSegment resolver) path
+  pure (PP.concatWith (\x y -> x <+> ":>" <+> y) segments)
+
+-- | Codegen a 'PathSegment'.
+codegenSegment :: Monad m => Resolver m -> PathSegment Param -> m (PP.Doc ann)
+codegenSegment _resolver segment = case segment of
+  StaticSegment literal ->
+    pure ("\"" <> PP.pretty literal <> "\"")
+  VariableSegment Param {name, schema} -> do
+    code <- codegenParamSchema name schema
+    let capture =
+          "Capture" <+> "\"" <> toParamName name <> "\"" <+> code
+    pure capture
+
+codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann
+codegenPathGuard path continuation =
+  codegenPathPattern path <+> "->" <> PP.line
+    <> PP.indent
+      4
+      ( foldr
+          ($)
+          continuation
+          [codegenParamGuard param | VariableSegment param <- path]
+      )
+
+codegenParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
+codegenParamGuard Param {name} continuation =
+  "case" <+> "Web.HttpApiData.parseUrlPiece" <+> toParamBinder name <+> "of" <> PP.line
+    <> PP.indent
+      4
+      ( "Left" <+> "_" <+> "->" <+> "invalidRequest" <+> "\"" <> toParamName name <> "\"" <> PP.line
+          <> "Right" <+> toParamBinder name <+> "->"
+          <> PP.line
+          <> PP.indent 4 continuation
+      )
+
+codegenPathPattern :: Path -> PP.Doc ann
+codegenPathPattern path =
+  "["
+    <+> PP.concatWith
+      (\x y -> x <> "," <+> y)
+      (map codegenPathSegmentPattern path)
+    <+> "]"
+
+codegenPathSegmentPattern :: PathSegment Param -> PP.Doc ann
+codegenPathSegmentPattern segment = case segment of
+  StaticSegment literal ->
+    "\"" <> PP.pretty literal <> "\""
+  VariableSegment Param {name} ->
+    toParamBinder name
+
+codegenMethodGuard :: [(Text, PP.Doc ann)] -> PP.Doc ann
+codegenMethodGuard methodBodies =
+  "case" <+> "Network.Wai.requestMethod" <+> "request" <+> "of" <> PP.line
+    <> PP.indent
+      4
+      ( PP.vsep $
+          [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body
+            | (method, body) <- methodBodies
+          ]
+            ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x")
+               ]
+      )
+
+codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann
+codegenRequestBodyGuard requestBody continuation = case requestBody of
+  Nothing -> continuation
+  Just _body ->
+    "do"
+      <+> PP.align
+        ( "result" <+> "<-" <+> "Data.Attoparsec.ByteString.parseWith" <+> "(" <> "Network.Wai.getRequestBodyChunk" <+> "request" <> ")" <+> "Data.Aeson.Parser.json'" <+> "mempty" <> PP.line
+            <> "case" <+> "Data.Attoparsec.ByteString.eitherResult" <+> "result" <+> "of"
+            <> PP.line
+            <> PP.indent
+              4
+              ( "Left" <+> "_err" <+> "->" <+> "undefined" <> PP.line
+                  <> "Right" <+> "bodyValue" <+> "->"
+                  <> PP.line
+                  <> PP.indent
+                    4
+                    ( "case" <+> "Data.Aeson.Types.parseEither" <+> "Data.Aeson.parseJSON" <+> "bodyValue" <+> "of" <> PP.line
+                        <> PP.indent
+                          4
+                          ( "Left" <+> "_err" <+> "->" <+> "undefined" <> PP.line
+                              <> "Right" <+> "body" <+> "->"
+                              <> PP.line
+                              <> PP.indent 4 continuation
+                          )
+                    )
+              )
+        )

src/Tie/Codegen/Response.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Codegen.Response
+  ( codegenResponses,
+    codegenResponseAuxFile,
+  )
+where
+
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+import Tie.Codegen.Schema (codegenFieldType, codegenParamSchema)
+import Tie.Name
+  ( Name,
+    toApiDefaultResponseConstructorName,
+    toApiMemberName,
+    toApiResponseConstructorName,
+    toApiResponseTypeName,
+    toParamBinder,
+    toParamName,
+  )
+import Tie.Operation
+  ( Operation (..),
+    Param (..),
+    Path,
+    PathSegment (..),
+    RequestBody (..),
+    Response (..),
+  )
+import Tie.Resolve (Resolver)
+
+-- | Generate code for the responses of an 'Operation'.
+codegenResponses :: Monad m => Resolver m -> Operation -> m (Doc ann)
+codegenResponses resolver Operation {..} = do
+  let decl =
+        "data" <+> toApiResponseTypeName name <> PP.line
+          <> PP.indent
+            4
+            ( PP.vsep $
+                [ op <+> toApiResponseConstructorName name statusCode <+> codegenFieldType jsonResponseContent
+                  | (op, (statusCode, Response {jsonResponseContent})) <- zip ("=" : repeat "|") responses
+                ]
+                  ++ [ "|" <+> toApiDefaultResponseConstructorName name
+                         <+> "Network.HTTP.Types.Status"
+                         <+> codegenFieldType jsonResponseContent
+                       | Just Response {jsonResponseContent} <- [defaultResponse]
+                     ]
+            )
+      instances =
+        codegenToResponses name responses defaultResponse
+
+  pure (PP.vsep [decl, mempty, instances])
+
+codegenToResponses :: Name -> [(Int, Response)] -> Maybe Response -> Doc ann
+codegenToResponses operationName responses defaultResponse =
+  let decl =
+        "instance" <+> "ToResponse" <+> toApiResponseTypeName operationName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( PP.vsep $
+                [ "toResponse" <+> "(" <> toApiResponseConstructorName operationName statusCode <+> "x" <> ")"
+                    <+> "="
+                    <> PP.line
+                    <> PP.indent
+                      4
+                      ( "Network.Wai.responseBuilder" <+> "(" <> "toEnum" <+> PP.pretty statusCode <> ")"
+                          <+> "[(Network.HTTP.Types.hContentType, \"application/json\")]"
+                          <+> "(" <> "Data.Aeson.fromEncoding"
+                          <+> "(" <> "Data.Aeson.toEncoding"
+                          <+> "x" <> ")" <> ")"
+                      )
+                  | (statusCode, _response) <- responses
+                ]
+                  ++ [ "toResponse" <+> "(" <> toApiDefaultResponseConstructorName operationName <+> "status" <+> "x" <> ")"
+                         <+> "="
+                         <> PP.line
+                         <> PP.indent
+                           4
+                           ( "Network.Wai.responseBuilder" <+> "status"
+                               <+> "[(Network.HTTP.Types.hContentType, \"application/json\")]"
+                               <+> "(" <> "Data.Aeson.fromEncoding"
+                               <+> "(" <> "Data.Aeson.toEncoding"
+                               <+> "x" <> ")" <> ")"
+                           )
+                       | Just Response {jsonResponseContent} <- [defaultResponse]
+                     ]
+            )
+   in decl
+
+codegenResponseAuxFile :: Doc ann
+codegenResponseAuxFile =
+  "class"
+    <+> "ToResponse"
+    <+> "a"
+    <+> "where"
+      <> PP.line
+      <> PP.indent
+        4
+        ( "toResponse" <+> "::" <+> "a" <+> "->" <+> "Network.Wai.Response"
+        )

src/Tie/Codegen/Schema.hs

@@ -0,0 +1,324 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Codegen.Schema
+  ( codegenSchema,
+    codegenParamSchema,
+    codegenFieldType,
+  )
+where
+
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.HashSet as HashSet
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+import Tie.Name
+  ( inlineObjectTypeName,
+    inlineVariantTypeName,
+    toConstructorName,
+    toDataTypeName,
+    toFieldName,
+    toFunctionName,
+    toJsonFieldName,
+    toOneOfConstructorName,
+    toOneOfDataTypeName,
+  )
+import Tie.Type
+  ( BasicType (..),
+    Enumeration (..),
+    Name,
+    Named (..),
+    ObjectType (..),
+    Type (..),
+    isArrayType,
+    isBasicType,
+    isEnumType,
+    isObjectType,
+    isOneOfType,
+    namedType,
+    normalizeObjectType,
+    normalizeVariants,
+  )
+import Prelude hiding (Type)
+
+-- | Generate code for a parameter type.
+codegenParamSchema :: Monad m => Name -> Named Type -> m (Doc ann)
+codegenParamSchema _paramName typ = case typ of
+  Named {} ->
+    -- We are named, just defer to codegenFieldType
+    pure (codegenFieldType typ)
+  Unnamed typ
+    | Just _enumeration <- isEnumType typ ->
+      error "TODO enumeration params"
+    | Just basicType <- isBasicType typ ->
+      pure (codegenFieldType (Unnamed typ))
+    | Just objectType <- isObjectType typ ->
+      error "Invariant broken: ruled out by pathToPath"
+    | otherwise ->
+      undefined
+
+-- | Generate code for a schema.
+codegenSchema :: Monad m => Name -> Type -> m (Doc ann)
+codegenSchema typName typ
+  | Just Enumeration {alternatives, includeNull} <- isEnumType typ =
+    pure (codegenEnumeration typName alternatives includeNull)
+  | Just basicType <- isBasicType typ =
+    pure (codegenBasicType typName basicType)
+  | Just alternatives <- isOneOfType typ =
+    codegenOneOfType typName alternatives
+  | Just objectType <- isObjectType typ =
+    codegenObjectType typName objectType
+  | Just elemType <- isArrayType typ =
+    codegenArrayType typName elemType
+  | otherwise =
+    undefined
+
+-- | Generate code for basic, primitive types
+codegenBasicType :: Name -> BasicType -> Doc ann
+codegenBasicType typName basicType =
+  let typ = case basicType of
+        TyString {} ->
+          "Data.Text.Text"
+        TyEnum {} ->
+          error "Impossible: Enumerations are handled by codegenEnumeration"
+        TyNumber ->
+          "GHC.Types.Double"
+        TyInteger ->
+          "GHC.Types.Int"
+        TyBoolean ->
+          "GHC.Types.Bool"
+   in "type" <+> toDataTypeName typName <+> "=" <+> typ
+
+codegenArrayType :: Monad m => Name -> Named Type -> m (Doc ann)
+codegenArrayType name typ = pure mempty
+
+codegenOneOfType :: Monad m => Name -> [Named Type] -> m (Doc ann)
+codegenOneOfType typName variants = do
+  -- Extract the inline dependencies, we will codegen them into the same file.
+  (variants, inlineDependencies) <-
+    normalizeVariants
+      ( \ith _variantType ->
+          pure (inlineVariantTypeName typName ith)
+      )
+      variants
+
+  -- Generate code for inline dependencies inplace
+  codeForInlineDependencies <-
+    traverse (uncurry codegenSchema) inlineDependencies
+
+  let -- We derive the constructor names upfront. For unnamed types - which can still
+      -- exists after normalization for e.g. basic types - we generate an inline variant
+      -- type name.
+      variantConstructors =
+        [ (name, variant)
+          | (ith, variant) <- zip [1 ..] variants,
+            let name = case variant of
+                  Named variantName _ ->
+                    toOneOfConstructorName typName variantName
+                  Unnamed typ ->
+                    toOneOfConstructorName typName (inlineVariantTypeName typName ith)
+        ]
+
+      decl =
+        "data" <+> toOneOfDataTypeName typName <> PP.line
+          <> PP.indent
+            4
+            ( PP.vsep
+                [ op
+                    <+> variantName
+                    <+> codegenFieldType variantType
+                  | (op, (variantName, variantType)) <- zip ("=" : repeat "|") variantConstructors
+                ]
+            )
+
+      toJson =
+        "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( PP.vsep
+                [ "toJSON" <+> "(" <> variantName <+> "x" <> ")" <+> "="
+                    <+> "Data.Aeson.toJSON"
+                    <+> "x"
+                  | (variantName, _) <- variantConstructors
+                ]
+            )
+
+      fromJson =
+        "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "parseJSON" <+> "x" <+> "=" <> PP.line
+                <> PP.indent
+                  4
+                  ( PP.concatWith
+                      (\x y -> x <+> "Control.Applicative.<|>" <> PP.line <> y)
+                      [ "(" <> variantName <+> "<$>" <+> "Data.Aeson.parseJSON" <+> "x" <> ")"
+                        | (variantName, variantType) <- variantConstructors
+                      ]
+                  )
+            )
+
+  pure $
+    PP.vsep
+      ( (map (<> PP.line) codeForInlineDependencies)
+          ++ [decl, mempty, toJson, mempty, fromJson]
+      )
+
+codegenObjectType :: Monad m => Name -> ObjectType (Named Type) -> m (Doc ann)
+codegenObjectType typName inputObjectType = do
+  -- Extract the inline dependencies, we will codegen them into the same file.
+  (ObjectType {..}, inlineDependencies) <-
+    normalizeObjectType
+      ( \fieldName _inlineObjectType ->
+          pure (inlineObjectTypeName typName fieldName)
+      )
+      inputObjectType
+
+  -- Generate code for inline dependencies inplace
+  codeForInlineDependencies <-
+    traverse (uncurry codegenSchema) inlineDependencies
+
+  -- Now generate for the object itself
+  let orderedProperties =
+        sortOn fst (HashMap.toList properties)
+
+      dataOrNewtype = case orderedProperties of
+        [_] -> "newtype"
+        _ -> "data"
+
+      decl =
+        dataOrNewtype <+> toDataTypeName typName <+> "=" <+> toConstructorName typName <> PP.line
+          <> PP.indent
+            4
+            ( "{" <> PP.line
+                <> PP.indent
+                  4
+                  ( PP.concatWith
+                      (\x y -> x <> "," <> PP.line <> y)
+                      [ toFieldName field <+> "::"
+                          <+> codegenRequiredOptionalFieldType
+                            (HashSet.member field requiredProperties)
+                            (codegenFieldType fieldType)
+                        | (field, fieldType) <- orderedProperties
+                      ]
+                  )
+                <> PP.line
+                <> "}"
+            )
+
+      toJson =
+        "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "toJSON" <+> toConstructorName typName <+> "{..}" <+> "=" <+> "Data.Aeson.object" <> PP.line
+                <> PP.indent
+                  4
+                  ( "[" <> PP.line
+                      <> PP.indent
+                        4
+                        ( PP.concatWith
+                            (\x y -> x <> "," <> PP.line <> y)
+                            [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName field
+                              | (field, _) <- orderedProperties
+                            ]
+                        )
+                      <> PP.line
+                      <> "]"
+                  )
+            )
+
+      fromOptOrReq field
+        | HashSet.member field requiredProperties = "Data.Aeson..:"
+        | otherwise = "Data.Aeson..:?"
+
+      fromJson =
+        "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "parseJSON" <+> "=" <+> "Data.Aeson.withObject" <+> "\"" <> toDataTypeName typName <> "\"" <+> "$" <+> "\\" <> "o" <+> "->" <> PP.line
+                <> PP.indent
+                  4
+                  ( toConstructorName typName <> PP.line
+                      <> PP.indent
+                        4
+                        ( PP.vsep
+                            [ op <+> "o" <+> fromOptOrReq fieldName <+> "\"" <> toJsonFieldName fieldName <> "\""
+                              | (op, (fieldName, _)) <- zip ("<$>" : repeat "<*>") orderedProperties
+                            ]
+                        )
+                  )
+            )
+   in pure $
+        PP.vsep
+          ( (map (<> PP.line) codeForInlineDependencies)
+              ++ [decl, mempty, toJson, mempty, fromJson]
+          )
+
+codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann
+codegenRequiredOptionalFieldType True doc = doc
+codegenRequiredOptionalFieldType False doc = "Data.Maybe.Maybe" <+> "(" <> doc <> ")"
+
+codegenFieldType :: Named Type -> Doc ann
+codegenFieldType namedType = case namedType of
+  Named name _ -> toDataTypeName name
+  Unnamed typ -> case typ of
+    AllOf {} -> "error: allOf"
+    AnyOf {} -> "error: anyOf"
+    OneOf {} -> "error: oneOf"
+    Not {} -> "error: not"
+    Basic basicType -> case basicType of
+      TyString {} -> "Data.Text.Text"
+      TyEnum {} -> "error: Enum"
+      TyNumber -> "GHC.Types.Double"
+      TyInteger -> "GHC.Types.Int"
+      TyBoolean -> "GHC.Types.Bool"
+    Object objectType -> "Data.Aeson.Value"
+    Array elemType -> "[" <+> codegenFieldType elemType <+> "]"
+
+-- | Generate the Haskell code for enumeration types
+codegenEnumeration :: Name -> [Text] -> Bool -> Doc ann
+codegenEnumeration typName alternatives _includeNull =
+  let dataDecl =
+        "data"
+          <+> toDataTypeName typName
+            <> PP.line
+            <> PP.indent
+              4
+              ( "="
+                  <+> PP.concatWith
+                    (\x y -> x <> PP.line <> "|" <+> y)
+                    (map PP.pretty alternatives)
+                    <> PP.line
+                    <> "deriving"
+                  <+> "(" <> "Eq" <> ","
+                  <+> "Show" <> ")"
+              )
+      toJSON =
+        "instance" <+> "Data.Aeson.ToJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "toJSON" <+> "x" <+> "=" <+> "case" <+> "x" <+> "of" <> PP.line
+                <> PP.indent
+                  4
+                  ( PP.vsep
+                      [ PP.pretty alt <+> "->" <+> "\"" <+> PP.pretty alt <+> "\""
+                        | alt <- alternatives
+                      ]
+                  )
+            )
+      fromJSON =
+        "instance" <+> "Data.Aeson.FromJSON" <+> toDataTypeName typName <+> "where" <> PP.line
+          <> PP.indent
+            4
+            ( "parseJSON" <+> "=" <+> "withText" <+> "\"" <+> toDataTypeName typName <+> "\"" <+> "$" <+> "\\" <+> "s" <+> "->" <> PP.line
+                <> PP.indent
+                  4
+                  ( PP.vsep
+                      [ "\"" <> PP.pretty alt <> "\"" <+> "->" <+> PP.pretty alt
+                        | alt <- alternatives
+                      ]
+                  )
+            )
+   in PP.vsep [dataDecl, PP.line, toJSON, PP.line, fromJSON]

src/Tie/Name.hs

@@ -0,0 +1,198 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Tie.Name
+  ( PackageName,
+    ApiName,
+    Name,
+    fromText,
+    cabalFileName,
+    toDataTypeName,
+    toOneOfDataTypeName,
+    toOneOfConstructorName,
+    toFunctionName,
+    toConstructorName,
+    toFieldName,
+    toJsonFieldName,
+    toParamName,
+    toParamBinder,
+    toApiTypeName,
+    toSchemaHaskellFileName,
+    toSchemaHaskellModuleName,
+    toOperationHaskellFileName,
+    toOperationHaskellModuleName,
+    toResponseHaskellFileName,
+    toResponseHaskellModuleName,
+    apiHaskellModuleName,
+    apiHaskellFileName,
+    responseHaskellModuleName,
+    responseHaskellFileName,
+    inlineObjectTypeName,
+    inlineVariantTypeName,
+    toApiResponseTypeName,
+    toApiResponseConstructorName,
+    toApiDefaultResponseConstructorName,
+    toApiMemberName,
+  )
+where
+
+import Data.Char (toLower, toUpper)
+import qualified Data.Text as Text
+import qualified Prettyprinter as PP
+
+-- | Name of the API to generate code for
+type ApiName = Text
+
+-- | Cabal package name
+type PackageName = Text
+
+-- | Names identify things in the OpenApi universe. Name's are coming directly
+-- from the OpenApi spec.
+newtype Name = Name {unName :: Text}
+  deriving (IsString, Eq, Ord, Show, Hashable)
+
+fromText :: Text -> Name
+fromText = Name
+
+cabalFileName :: PackageName -> FilePath
+cabalFileName packageName =
+  Text.unpack packageName <> ".cabal"
+
+apiHaskellModuleName :: ApiName -> Text
+apiHaskellModuleName apiName =
+  apiName <> ".Api"
+
+apiHaskellFileName :: ApiName -> FilePath
+apiHaskellFileName apiName =
+  Text.unpack apiName <> "/Api.hs"
+
+responseHaskellModuleName :: ApiName -> Text
+responseHaskellModuleName apiName =
+  apiName <> ".Response"
+
+responseHaskellFileName :: ApiName -> FilePath
+responseHaskellFileName apiName =
+  Text.unpack apiName <> "/Response.hs"
+
+toSchemaHaskellModuleName :: ApiName -> Name -> Text
+toSchemaHaskellModuleName apiName (Name name) =
+  Text.pack $ Text.unpack apiName <> ".Schemas." <> capitalizeFirstLetter (Text.unpack name)
+
+toSchemaHaskellFileName :: ApiName -> Name -> FilePath
+toSchemaHaskellFileName apiName (Name name) =
+  Text.unpack apiName <> "/Schemas/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs"
+
+toOperationHaskellModuleName :: ApiName -> Name -> Text
+toOperationHaskellModuleName apiName (Name name) =
+  Text.pack $ Text.unpack apiName <> ".Api." <> capitalizeFirstLetter (Text.unpack name)
+
+toOperationHaskellFileName :: ApiName -> Name -> FilePath
+toOperationHaskellFileName apiName (Name name) =
+  Text.unpack apiName <> "/Api/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs"
+
+toResponseHaskellModuleName :: ApiName -> Name -> Text
+toResponseHaskellModuleName apiName (Name name) =
+  Text.pack $ Text.unpack apiName <> ".Response." <> capitalizeFirstLetter (Text.unpack name)
+
+toResponseHaskellFileName :: ApiName -> Name -> FilePath
+toResponseHaskellFileName apiName (Name name) =
+  Text.unpack apiName <> "/Response/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs"
+
+toApiTypeName :: Name -> PP.Doc ann
+toApiTypeName =
+  toDataTypeName
+
+toJsonFieldName :: Name -> PP.Doc ann
+toJsonFieldName = PP.pretty . unName
+
+toDataTypeName :: Name -> PP.Doc ann
+toDataTypeName =
+  PP.pretty . Text.pack . capitalizeFirstLetter . Text.unpack . unName
+
+toOneOfDataTypeName :: Name -> PP.Doc ann
+toOneOfDataTypeName =
+  PP.pretty . Text.pack . capitalizeFirstLetter . Text.unpack . unName
+
+toOneOfConstructorName :: Name -> Name -> PP.Doc ann
+toOneOfConstructorName (Name oneOfType) (Name variant) =
+  PP.pretty $
+    Text.pack $
+      escapeKeyword $
+        capitalizeFirstLetter (Text.unpack oneOfType)
+          <> capitalizeFirstLetter (Text.unpack variant)
+
+toConstructorName :: Name -> PP.Doc ann
+toConstructorName = toDataTypeName
+
+toFunctionName :: Name -> PP.Doc ann
+toFunctionName =
+  PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName
+
+toFieldName :: Name -> PP.Doc ann
+toFieldName =
+  PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName
+
+toParamName :: Name -> PP.Doc ann
+toParamName =
+  PP.pretty . unName
+
+toParamBinder :: Name -> PP.Doc ann
+toParamBinder =
+  PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName
+
+toApiMemberName :: Name -> PP.Doc ann
+toApiMemberName =
+  PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . Text.unpack . unName
+
+toApiResponseTypeName :: Name -> PP.Doc ann
+toApiResponseTypeName =
+  PP.pretty . Text.pack . escapeKeyword . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName
+
+toApiResponseConstructorName :: Name -> Int -> PP.Doc ann
+toApiResponseConstructorName name statusCode =
+  PP.pretty . Text.pack . escapeKeyword . (<> show statusCode) . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName $ name
+
+toApiDefaultResponseConstructorName :: Name -> PP.Doc ann
+toApiDefaultResponseConstructorName name =
+  PP.pretty . Text.pack . escapeKeyword . (<> "DefaultResponse") . capitalizeFirstLetter . Text.unpack . unName $ name
+
+-- | Constructs a name for an object defined inline. Based on the containing data
+-- type as well as the field name.
+inlineObjectTypeName :: Name -> Name -> Name
+inlineObjectTypeName (Name parentType) (Name fieldName) =
+  Name $
+    Text.pack $
+      escapeKeyword $
+        capitalizeFirstLetter (Text.unpack parentType)
+          <> capitalizeFirstLetter (Text.unpack fieldName)
+
+-- | Construct a name for an inline type in a oneOf.
+inlineVariantTypeName :: Name -> Int -> Name
+inlineVariantTypeName (Name parentType) ith =
+  Name $
+    Text.pack $
+      escapeKeyword $
+        capitalizeFirstLetter (Text.unpack parentType) <> "OneOf" <> show ith
+
+lowerFirstLetter :: String -> String
+lowerFirstLetter [] = []
+lowerFirstLetter (x : xs) = toLower x : xs
+
+capitalizeFirstLetter :: String -> String
+capitalizeFirstLetter [] = []
+capitalizeFirstLetter (x : xs) = toUpper x : xs
+
+escapeKeyword :: String -> String
+escapeKeyword input = case input of
+  "type" -> "type'"
+  "class" -> "class'"
+  "where" -> "where'"
+  "case" -> "case'"
+  "of" -> "of'"
+  "data" -> "data'"
+  "import" -> "import'"
+  "qualified" -> "qualified'"
+  "as" -> "as'"
+  "instance" -> "instance'"
+  "module" -> "module'"
+  _ -> input

src/Tie/Operation.hs

@@ -0,0 +1,330 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Operation
+  ( StatusCode,
+    Param (..),
+    RequestBody (..),
+    Response (..),
+    Operation (..),
+    pathItemsToOperation,
+    operationToOperation,
+
+    -- * Errors
+    Errors (..),
+    errors,
+
+    -- * Path
+    Path,
+    PathSegment (..),
+    parsePath,
+
+    -- * Dependencies
+    operationSchemaDependencies,
+    operationResponseDependencies,
+  )
+where
+
+import qualified Data.HashMap.Strict.InsOrd as InsOrd
+import qualified Data.OpenApi as OpenApi
+import qualified Data.Text as Text
+import Tie.Name (Name, fromText)
+import Tie.Resolve (Resolver, resolve)
+import Tie.Type
+  ( Named,
+    Type,
+    isBasicType,
+    namedType,
+    namedTypeDependencies,
+    schemaRefToType,
+  )
+import Prelude hiding (Type)
+
+-- | HTTP Status code type
+type StatusCode = Int
+
+-- | Request body descriptor
+data RequestBody = RequestBody
+  { jsonRequestBodyContent :: Named Type
+  }
+
+-- | Response descriptor
+data Response = Response
+  { -- | JSON schema of the response
+    jsonResponseContent :: Named Type
+  }
+
+-- | Internal representation of a path.
+data PathSegment variable
+  = StaticSegment Text
+  | VariableSegment variable
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+-- | Internal representation of a Path
+type Path = [PathSegment Param]
+
+data ParamIn
+  = InPath
+  | InQuery
+  | InHeader
+  | InCookie
+  deriving (Eq, Ord, Show)
+
+data Param = Param
+  { name :: Name,
+    paramIn :: ParamIn,
+    schema :: Named Type,
+    required :: Bool
+  }
+
+-- | Internal representation for an 'OpenApi.Operation'.
+data Operation = Operation
+  { -- | Name of the operation. Used for identifiers.
+    name :: Name,
+    -- | Path
+    path :: Path,
+    -- | HTTP method for this operation (Get, Post, Put, Delete)
+    method :: Text,
+    -- | Type of the request body (if any) for this 'Operation'.
+    requestBody :: Maybe RequestBody,
+    -- | Default response.
+    defaultResponse :: Maybe Response,
+    -- | Responses
+    responses :: [(StatusCode, Response)]
+  }
+
+data Errors m = Errors
+  { missingOperationId :: forall a. m a,
+    unsupportedMediaType :: forall a. m a,
+    requestBodyMissingSchema :: forall a. m a,
+    unknownParameter :: forall a. Text -> m a,
+    paramMissingSchema :: forall a. m a,
+    paramNotInPath :: forall a. m a,
+    paramNotBasicType :: forall a. m a
+  }
+
+errors :: Errors m
+errors =
+  Errors
+    { missingOperationId =
+        error "missing operation id",
+      unsupportedMediaType =
+        error "unsupported media type",
+      requestBodyMissingSchema =
+        error "request body missing media type",
+      unknownParameter =
+        error "unknown parameter",
+      paramMissingSchema =
+        error "param missing schema",
+      paramNotInPath =
+        error "param not 'in path' type",
+      paramNotBasicType =
+        error "only basic types are supported for parameters"
+    }
+
+-- | Returns the dependencies on schemas of an operation. Parameterized so
+-- that shallow vs. all transitive dependencies can be extracted.
+operationSchemaDependencies :: (Named Type -> [Name]) -> Operation -> [Name]
+operationSchemaDependencies getDependencies Operation {..} =
+  concat $
+    [ getDependencies jsonRequestBodyContent
+      | Just RequestBody {jsonRequestBodyContent} <- [requestBody]
+    ]
+      ++ [ getDependencies jsonResponseContent
+           | Just Response {jsonResponseContent} <- [defaultResponse]
+         ]
+      ++ [ getDependencies jsonResponseContent
+           | (_, Response {jsonResponseContent}) <- responses
+         ]
+
+-- | Dependencies in the Response.* modules.
+operationResponseDependencies :: Operation -> [Name]
+operationResponseDependencies Operation {name} = [name]
+
+pathItemsToOperation ::
+  Monad m =>
+  Resolver m ->
+  -- | Conversion error cases
+  Errors m ->
+  -- | URLs
+  [(FilePath, OpenApi.PathItem)] ->
+  m [Operation]
+pathItemsToOperation resolver errors@Errors {..} pathInfos = do
+  items <- forM pathInfos $ \(path, OpenApi.PathItem {..}) -> do
+    get <-
+      forM _pathItemGet (operationToOperation resolver errors "GET" path _pathItemParameters)
+    put <-
+      forM _pathItemPut (operationToOperation resolver errors "PUT" path _pathItemParameters)
+    post <-
+      forM _pathItemPost (operationToOperation resolver errors "POST" path _pathItemParameters)
+    delete <-
+      forM _pathItemDelete (operationToOperation resolver errors "DELETE" path _pathItemParameters)
+    options <-
+      forM _pathItemOptions (operationToOperation resolver errors "OPTIONS" path _pathItemParameters)
+    head <-
+      forM _pathItemHead (operationToOperation resolver errors "HEAD" path _pathItemParameters)
+    patch <-
+      forM _pathItemPatch (operationToOperation resolver errors "PATCH" path _pathItemParameters)
+    trace <-
+      forM _pathItemTrace (operationToOperation resolver errors "TRACE" path _pathItemParameters)
+    pure (catMaybes [get, put, post, delete, options, head, patch, trace])
+  pure (concat items)
+
+-- TODO name
+operationToOperation ::
+  Monad m =>
+  Resolver m ->
+  -- | Conversion error cases
+  Errors m ->
+  -- | HTTP Method
+  Text ->
+  -- | Path
+  FilePath ->
+  -- | Params defined at the PathItem level
+  [OpenApi.Referenced OpenApi.Param] ->
+  OpenApi.Operation ->
+  m Operation
+operationToOperation resolver errors@Errors {..} method path params OpenApi.Operation {..} = do
+  operationId <-
+    whenNothing _operationOperationId missingOperationId
+  path <-
+    pathToPath
+      resolver
+      errors
+      path
+      -- Operations override pathItem params
+      (_operationParameters ++ params)
+  requestBody <- forM _operationRequestBody $ \referencedRequestBody -> do
+    requestBody <- resolve resolver referencedRequestBody
+    requestBodyToRequestBody resolver errors requestBody
+  defaultResponse <- forM (OpenApi._responsesDefault _operationResponses) $ \referencedResponse -> do
+    response <- resolve resolver referencedResponse
+    responseToResponse resolver errors response
+  responses <- forM (InsOrd.toList (OpenApi._responsesResponses _operationResponses)) $ \(statusCode, referencedResponse) -> do
+    response <- resolve resolver referencedResponse
+    (,) <$> pure statusCode <*> responseToResponse resolver errors response
+  pure
+    Operation
+      { name = fromText operationId,
+        ..
+      }
+
+requestBodyToRequestBody ::
+  Monad m =>
+  Resolver m ->
+  Errors m ->
+  OpenApi.RequestBody ->
+  m RequestBody
+requestBodyToRequestBody resolver Errors {..} requestBody = do
+  -- TODO support form inputs as well
+  OpenApi.MediaTypeObject {..} <-
+    whenNothing
+      (InsOrd.lookup "application/json" (OpenApi._requestBodyContent requestBody))
+      unsupportedMediaType
+  referencedSchema <-
+    whenNothing
+      _mediaTypeObjectSchema
+      requestBodyMissingSchema
+  type_ <-
+    schemaRefToType resolver referencedSchema
+  pure
+    RequestBody
+      { jsonRequestBodyContent = type_
+      }
+
+responseToResponse ::
+  Monad m =>
+  Resolver m ->
+  Errors m ->
+  OpenApi.Response ->
+  m Response
+responseToResponse resolver Errors {..} response = do
+  OpenApi.MediaTypeObject {..} <-
+    whenNothing
+      (InsOrd.lookup "application/json" (OpenApi._responseContent response))
+      unsupportedMediaType
+  -- TODO take care of headers
+  referencedSchema <-
+    whenNothing
+      _mediaTypeObjectSchema
+      requestBodyMissingSchema
+  type_ <-
+    schemaRefToType resolver referencedSchema
+  pure
+    Response
+      { jsonResponseContent = type_
+      }
+
+parsePath :: FilePath -> [PathSegment Text]
+parsePath path =
+  let toPathSegment s
+        | Just s <- Text.stripPrefix "{" s,
+          Just s <- Text.stripSuffix "}" s =
+          VariableSegment s
+        | otherwise =
+          StaticSegment s
+   in case Text.splitOn "/" (toText path) of
+        -- leading / results in a leading empty string after split
+        "" : segments ->
+          map toPathSegment segments
+        segments ->
+          -- TODO this is probably an error
+          map toPathSegment segments
+
+paramToParam ::
+  Monad m =>
+  Resolver m ->
+  Errors m ->
+  OpenApi.Param ->
+  m Param
+paramToParam resolver Errors {..} OpenApi.Param {..} = do
+  schema <- whenNothing _paramSchema paramMissingSchema
+  typ <- schemaRefToType resolver schema
+  pure
+    Param
+      { name = fromText _paramName,
+        paramIn = case _paramIn of
+          OpenApi.ParamQuery -> InQuery
+          OpenApi.ParamHeader -> InHeader
+          OpenApi.ParamPath -> InPath
+          OpenApi.ParamCookie -> InCookie,
+        required = fromMaybe False _paramRequired,
+        schema = typ
+      }
+
+pathToPath ::
+  Monad m =>
+  Resolver m ->
+  Errors m ->
+  -- | URL Path
+  FilePath ->
+  -- | Available 'OpenApi.Param's
+  [OpenApi.Referenced OpenApi.Param] ->
+  m Path
+pathToPath resolver errors@Errors {..} textualPath availableParams = do
+  let path = parsePath textualPath
+  params <- traverse (resolve resolver) availableParams
+  forM path $ \segment ->
+    forM segment $ \paramName -> do
+      param <-
+        whenNothing
+          ( find
+              (\x -> OpenApi._paramName x == paramName)
+              params
+          )
+          (unknownParameter paramName)
+      param <- paramToParam resolver errors param
+      when
+        (paramIn param /= InPath)
+        paramNotInPath
+      _ <-
+        whenNothing
+          (isBasicType (namedType (schema param)))
+          paramNotBasicType
+      pure param

src/Tie/Resolve.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Resolve
+  ( Resolvable,
+    Resolver,
+    newResolver,
+    resolve,
+  )
+where
+
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.HashMap.Strict.InsOrd as InsOrd
+import qualified Data.OpenApi as OpenApi
+import qualified Data.Text as Text
+
+-- | Resolve an 'OpenApi.Reference' to the underlying component.
+newtype Resolver m = Resolver
+  { resolve :: forall a. Resolvable a => OpenApi.Referenced a -> m a
+  }
+
+newResolver :: Applicative m => OpenApi.Components -> (forall a. OpenApi.Reference -> m a) -> Resolver m
+newResolver components notFound =
+  Resolver (resolveComponent components notFound)
+
+type ComponentName = Text
+
+resolveComponent ::
+  (Applicative m, Resolvable a) =>
+  -- | Inventory of components we can resolve to
+  OpenApi.Components ->
+  -- | What to do in case a 'OpenApi.Reference' is not found
+  (OpenApi.Reference -> m a) ->
+  -- | 'OpenApi.Reference' to resolve
+  OpenApi.Referenced a ->
+  m a
+resolveComponent components notFound = \referenced -> do
+  let (componentType, resolveComponent) = resolvables
+  case referenced of
+    OpenApi.Inline a ->
+      pure a
+    OpenApi.Ref reference
+      | Just a <-
+          InsOrd.lookup
+            (OpenApi.getReference reference)
+            (resolveComponent components) ->
+        pure a
+      | otherwise ->
+        notFound reference
+
+-- | Helper class helping to dispatch from 'OpenApi.Referenced' to component type @a@.
+class Resolvable a where
+  -- | Resolves the `OpenApi.Components` to the given corresponding `Definitions`.
+  resolvables :: (Text.Text, OpenApi.Components -> OpenApi.Definitions a)
+
+instance Resolvable OpenApi.Schema where
+  resolvables = ("schemas", OpenApi._componentsSchemas)
+
+instance Resolvable OpenApi.Response where
+  resolvables = ("responses", OpenApi._componentsResponses)
+
+instance Resolvable OpenApi.Param where
+  resolvables = ("parameters", OpenApi._componentsParameters)
+
+instance Resolvable OpenApi.Example where
+  resolvables = ("examples", OpenApi._componentsExamples)
+
+instance Resolvable OpenApi.RequestBody where
+  resolvables = ("requestBodies", OpenApi._componentsRequestBodies)

src/Tie/Type.hs

@@ -0,0 +1,410 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Tie.Type
+  ( StringFormat (..),
+    BasicType (..),
+    ObjectType (..),
+    Type (..),
+    Enumeration (..),
+    Name,
+    Named (..),
+    namedType,
+
+    -- * Conversion from 'OpenApi.Schema' to 'Type'.
+    schemaToType,
+    schemaRefToType,
+
+    -- * Accessors and operators working with 'Type'
+    isBasicType,
+    isEnumType,
+    isArrayType,
+    isObjectType,
+    isOneOfType,
+
+    -- * Normalize types
+    normalizeObjectType,
+    normalizeVariants,
+
+    -- * Dependencies
+    namedTypeDependencies,
+    transitiveDependencies,
+    typeDependencies,
+  )
+where
+
+import Control.Monad.Writer (runWriterT, tell)
+import qualified Data.Aeson as Aeson
+import Data.Foldable (foldr1)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.HashMap.Strict.InsOrd as InsOrd
+import qualified Data.HashSet as HashSet
+import qualified Data.OpenApi as OpenApi
+import qualified Data.Text as Text
+import Tie.Name (Name, fromText)
+import Tie.Resolve (Resolver, resolve)
+import Prelude hiding (Type)
+
+-- | Formats a String can have
+data StringFormat
+  = -- | Default for when there is no format defined in the type declaration.
+    FormatDefault
+  | -- | Full-date notation as defined by RFC 3339, section 5.6, for example, 2017-07-21
+    FormatDate
+  | -- | The date-time notation as defined by RFC 3339, section 5.6, for example, 2017-07-21T17:32:28Z
+    FormatDateTime
+  | -- | A hint to UIs to mask the input
+    FormatPassword
+  | -- | base64-encoded characters, for example, U3dhZ2dlciByb2Nrcw==
+    FormatByte
+  | -- | binary data, used to describe files
+    FormatBinary
+  deriving (Eq, Show)
+
+-- | Represents an OpenAPI enumeration.
+data Enumeration = Enumeration
+  { -- | The allowed values for this 'Enum'.
+    alternatives :: [Text],
+    -- | Whether 'null' is a valid 'Enum' value.
+    includeNull :: Bool
+  }
+  deriving (Eq, Show)
+
+-- | Basic types OpenAPI data types.
+data BasicType
+  = TyString {format :: StringFormat}
+  | TyEnum Enumeration
+  | TyNumber
+  | TyInteger
+  | TyBoolean
+  deriving (Eq, Show)
+
+-- | An object is a collection of property/value pairs.
+data ObjectType ty = ObjectType
+  { properties :: HashMap Name ty,
+    requiredProperties :: HashSet Name,
+    freeFormObjectType :: Bool
+  }
+  deriving (Eq, Show)
+
+-- | Our own version of 'OpenApi.Referenced'.
+data Named ty
+  = Named Name ty
+  | Unnamed ty
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+namedType :: Named ty -> ty
+namedType named = case named of
+  Named _ ty -> ty
+  Unnamed ty -> ty
+
+-- | This is our internal representation for 'OpenApi.Schema'. From 'Type' we derive
+-- the Haskell data types as well as the serialization code.
+data Type
+  = -- | OpenApi's allOf
+    AllOf [Named Type]
+  | -- | OpenApi's anyOf
+    AnyOf [Named Type]
+  | -- | OpenApi's oneOf
+    OneOf [Named Type]
+  | -- | OpenApi's not
+    Not (Named Type)
+  | -- | Basic, primitive types
+    Basic BasicType
+  | -- | Objects and it's properties
+    Object (ObjectType (Named Type))
+  | -- | Arrays of elements
+    Array (Named Type)
+  deriving (Eq, Show)
+
+-- | Casts a 'Type' to a 'BasicType' if possible.
+isBasicType :: Type -> Maybe BasicType
+isBasicType typ = case typ of
+  AllOf [x] -> isBasicType (namedType x)
+  AllOf {} -> Nothing
+  AnyOf [x] -> isBasicType (namedType x)
+  AnyOf {} -> Nothing
+  OneOf [x] -> isBasicType (namedType x)
+  OneOf {} -> Nothing
+  Not {} -> Nothing
+  Basic basicType -> Just basicType
+  Object {} -> Nothing
+  Array {} -> Nothing
+
+-- | Casts a 'Type' to an 'Enumeration' if possible.
+isEnumType :: Type -> Maybe Enumeration
+isEnumType typ
+  | Just (TyEnum enum) <- isBasicType typ =
+    Just enum
+  | otherwise =
+    Nothing
+
+schemaRefToType ::
+  Monad m =>
+  Resolver m ->
+  OpenApi.Referenced OpenApi.Schema ->
+  m (Named Type)
+schemaRefToType resolver referencedSchema = do
+  schema <- resolve resolver referencedSchema
+  case referencedSchema of
+    OpenApi.Ref reference ->
+      Named (fromText (OpenApi.getReference reference))
+        <$> schemaToType resolver schema
+    OpenApi.Inline schema -> do
+      Unnamed <$> schemaToType resolver schema
+
+-- | Converts an 'OpenApi.Schema' to our internal 'Type' representation.
+-- An optional 'ComponentName' indicates the name of component.
+schemaToType :: Monad m => Resolver m -> OpenApi.Schema -> m Type
+schemaToType resolver schema
+  | Just allOfsRefs <- OpenApi._schemaAllOf schema = do
+    AllOf <$> traverse (schemaRefToType resolver) allOfsRefs
+  | Just oneOfsRefs <- OpenApi._schemaOneOf schema =
+    OneOf <$> traverse (schemaRefToType resolver) oneOfsRefs
+  | Just anyOfRefs <- OpenApi._schemaAnyOf schema =
+    AnyOf <$> traverse (schemaRefToType resolver) anyOfRefs
+  | Just notOfRef <- OpenApi._schemaNot schema =
+    Not <$> schemaRefToType resolver notOfRef
+  | Just schemaType <- OpenApi._schemaType schema =
+    case schemaType of
+      OpenApi.OpenApiString ->
+        pure (Basic (schemaToStringyType schema))
+      OpenApi.OpenApiNumber ->
+        pure (Basic TyNumber)
+      OpenApi.OpenApiInteger ->
+        pure (Basic TyInteger)
+      OpenApi.OpenApiBoolean ->
+        pure (Basic TyBoolean)
+      OpenApi.OpenApiArray
+        | Just items <- OpenApi._schemaItems schema ->
+          case items of
+            OpenApi.OpenApiItemsObject itemsSchemaRef ->
+              Array <$> schemaRefToType resolver itemsSchemaRef
+            OpenApi.OpenApiItemsArray _itemsSchemaRefs ->
+              undefined -- TODO find out what tuple schemas are
+        | otherwise ->
+          undefined -- TODO array type without items
+      OpenApi.OpenApiNull ->
+        undefined -- TODO need a BasicType for that
+      OpenApi.OpenApiObject ->
+        Object <$> schemaToObjectType resolver schema
+  -- Heuristic: if the 'OpenApi.Schema' has properties attached
+  -- treat it as object.
+  | not (InsOrd.null (OpenApi._schemaProperties schema)) =
+    Object <$> schemaToObjectType resolver schema
+  -- It's an enum but without explicit "type: string"
+  | Just _enum <- OpenApi._schemaEnum schema =
+    pure (Basic (schemaToStringyType schema))
+  | otherwise =
+    traceShow schema undefined
+
+-- | Resolves an 'OpenApi.Schema' to an 'ObjectType'. In case the the 'OpenApi.Schema' is an
+-- allOf-schema. This function doesn't do any additional type checking.
+schemaToObjectType ::
+  Monad m =>
+  Resolver m ->
+  OpenApi.Schema ->
+  m (ObjectType (Named Type))
+schemaToObjectType resolver schema = do
+  properties <-
+    traverse
+      (schemaRefToType resolver)
+      (InsOrd.toHashMap (OpenApi._schemaProperties schema))
+  freeFormObjectType <- case OpenApi._schemaAdditionalProperties schema of
+    Nothing -> pure False
+    Just (OpenApi.AdditionalPropertiesAllowed allowed) -> pure allowed
+    Just (OpenApi.AdditionalPropertiesSchema schema) -> undefined -- TODO what exactly is this?
+  pure $
+    ObjectType
+      { freeFormObjectType,
+        properties = HashMap.mapKeys fromText properties,
+        requiredProperties =
+          HashSet.fromList (map fromText (OpenApi._schemaRequired schema))
+      }
+
+-- | Treat an 'OpenApi.Schema' as stringy. Accounts for enumerations
+-- as well. This function doesn't do any additional type checking.
+schemaToStringyType :: OpenApi.Schema -> BasicType
+schemaToStringyType schema
+  | Just enum <- OpenApi._schemaEnum schema = do
+    TyEnum $
+      Enumeration
+        { alternatives = [alt | Aeson.String alt <- enum],
+          includeNull = Aeson.Null `elem` enum
+        }
+  | otherwise =
+    TyString
+      { format = FormatDefault -- TODO
+      }
+
+-- | Extracts the shallow dependencies of a 'Type' by traversing the 'Type' and
+-- until we hit a 'Named' type.
+typeDependencies :: (Named Type -> [Name]) -> Type -> [Name]
+typeDependencies getDependencies ty =
+  -- For allOf, anyOf, oneOf look through all the dependencies - similar to what
+  -- we do in 'isObjectType'.
+  case ty of
+    AllOf allOfs ->
+      concatMap getDependencies allOfs
+    AnyOf anyOfs ->
+      concatMap getDependencies anyOfs
+    OneOf oneOfs ->
+      concatMap getDependencies oneOfs
+    Not not ->
+      typeDependencies getDependencies (namedType not)
+    Basic {} ->
+      []
+    Object objectType ->
+      objectTypeDependencies getDependencies objectType
+    Array elemType ->
+      getDependencies elemType
+
+-- | Dependencies of a 'Named Type'. This doesn't return transitive
+-- dependencies.
+namedTypeDependencies :: Named Type -> [Name]
+namedTypeDependencies named = case named of
+  Named name _elem ->
+    -- This is key: We don't want to descend into elem's type.
+    [name]
+  Unnamed elem ->
+    typeDependencies namedTypeDependencies elem
+
+-- | Extract all the transitive dependencies form a 'Named Type'.
+transitiveDependencies :: Named Type -> [Name]
+transitiveDependencies named = case named of
+  Named name typ ->
+    name : typeDependencies transitiveDependencies typ
+  Unnamed typ ->
+    typeDependencies transitiveDependencies typ
+
+-- | Dependencies of an 'ObjectType'.
+objectTypeDependencies :: (Named Type -> [Name]) -> ObjectType (Named Type) -> [Name]
+objectTypeDependencies getDependencies objectType =
+  concatMap getDependencies (toList (properties objectType))
+
+-- | Casting a 'Type' to the set of types it could be.
+isOneOfType :: Type -> Maybe [Named Type]
+isOneOfType ty = case ty of
+  OneOf oneOfs ->
+    Just oneOfs
+  _ ->
+    Nothing
+
+isArrayType :: Type -> Maybe (Named Type)
+isArrayType ty = case ty of
+  Array elem -> Just elem
+  _ -> Nothing
+
+-- | Casting a 'Type' to an 'ObjectType', if possible. `isObjectType` looks through
+-- allOf, oneOf, anyOf to ensure
+isObjectType :: Type -> Maybe (ObjectType (Named Type))
+isObjectType ty = case ty of
+  AllOf allOfs -> do
+    -- We have the choice: we could use traverse instead and fail
+    -- everything in case any subtype is not an Object. For now,
+    -- we ignore "type errors" and collect everything we get. I
+    -- found other code generators for OpenApi that behave that way.
+    let objects = catMaybes (map (isObjectType . namedType) allOfs)
+    pure (combine objects)
+  AnyOf anyOfs -> do
+    -- Look through all the objects, mark all of the properties optional
+    let objects =
+          [ object {requiredProperties = HashSet.empty}
+            | object <- catMaybes (map (isObjectType . namedType) anyOfs)
+          ]
+    pure (combine objects)
+  OneOf oneOfs -> do
+    -- Look through all the objects, mark all of the properties optional
+    let objects =
+          [ object {requiredProperties = HashSet.empty}
+            | object <- catMaybes (map (isObjectType . namedType) oneOfs)
+          ]
+    pure (combine objects)
+  Not {} -> Nothing
+  Basic {} -> Nothing
+  Object obj -> Just obj
+  Array {} -> Nothing
+  where
+    -- In principle this is Semigroup and Monoid instance. But it's too
+    -- early in the design to rely on that.
+    combine xs = case nonEmpty xs of
+      Nothing -> emptyObject
+      Just os -> foldr1 combineObjects os -- TODO make strict
+    emptyObject =
+      ObjectType
+        { properties = mempty,
+          requiredProperties = mempty,
+          freeFormObjectType = False
+        }
+
+    -- Combine two ObjectTypes. Doesn't report common fields!
+    combineObjects o1 o2 =
+      ObjectType
+        { properties = properties o1 <> properties o2,
+          requiredProperties = requiredProperties o1 <> requiredProperties o2,
+          freeFormObjectType = freeFormObjectType o1 || freeFormObjectType o2
+        }
+
+-- | OpenApi allows defining objects "inline". This function extracts inline objects
+-- and assigns names to them.
+--
+-- Invariant: The returned 'ObjectType' doesn't contain unnamed dependencies.
+normalizeObjectType ::
+  Monad m =>
+  (Name -> ObjectType (Named Type) -> m Name) ->
+  ObjectType (Named Type) ->
+  m (ObjectType (Named Type), [(Name, Type)])
+normalizeObjectType assignName objectType@ObjectType {..} = do
+  (properties, newTypes) <- runWriterT $
+    flip HashMap.traverseWithKey properties $ \fieldName fieldType ->
+      -- TODO we will probably have to handle enums here as well
+      case fieldType of
+        Unnamed typ
+          | Just objectType <- isObjectType typ -> do
+            name <- lift (assignName fieldName objectType)
+            tell [(name, Object objectType)]
+            pure (Named name (Object objectType))
+          -- TODO we need to recurse, otherwise we only support
+          -- one level deep arrays.
+          | Array (Unnamed elemType) <- typ,
+            Just objectType <- isObjectType elemType -> do
+            name <- lift (assignName fieldName objectType)
+            tell [(name, Object objectType)]
+            pure (Named name (Object objectType))
+        _ ->
+          pure fieldType
+  pure (objectType {properties}, newTypes)
+
+-- | Walk through the variants of a oneOf type. This function extracts inline objects
+-- and assigns names to them.
+--
+-- Invariant: The returned variants don't contain unnamed dependencies.
+normalizeVariants ::
+  Monad m =>
+  (Int -> Type -> m Name) ->
+  [Named Type] ->
+  m ([Named Type], [(Name, Type)])
+normalizeVariants assignName variants = runWriterT $
+  forM (zip [1 ..] variants) $ \(i, variant) -> do
+    -- TODO we will probably have to handle enums here as well
+    case variant of
+      Unnamed typ
+        | Just objectType <- isObjectType typ -> do
+          let typ = Object objectType
+          name <- lift (assignName i typ)
+          tell [(name, typ)]
+          pure (Named name typ)
+        -- TODO we need to recurse, otherwise we only support
+        -- one level deep arrays.
+        | Array (Unnamed elemType) <- typ,
+          Just objectType <- isObjectType elemType -> do
+          let typ = Object objectType
+          name <- lift (assignName i typ)
+          tell [(name, typ)]
+          pure (Named name typ)
+      _ ->
+        pure variant

src/Tie/Writer.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Tie.Writer
+  ( Writer,
+    fileWriter,
+    withTestWriter,
+  )
+where
+
+import Data.ByteString.Builder (Builder, writeFile)
+import Data.Text.Lazy.Encoding (encodeUtf8Builder)
+import Prettyprinter (Doc, (<+>))
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory, (</>))
+
+-- | Abstraction for storing generated code on disk.
+type Writer m = forall ann. FilePath -> Doc ann -> m ()
+
+-- | Renders a 'Doc' to a 'Builder' - ready to be written to disk.
+-- TODO move somewhere else
+render :: Doc ann -> Builder
+render =
+  encodeUtf8Builder . PP.renderLazy . PP.layoutPretty PP.defaultLayoutOptions
+
+-- | Renders 'Doc's to a file just as you would expect. Writes files relative
+-- to the given output directory.
+fileWriter :: MonadIO m => FilePath -> Writer m
+fileWriter outputDirectory path doc = liftIO $ do
+  let fullPath = outputDirectory </> path
+  createDirectoryIfMissing True (takeDirectory fullPath)
+  Data.ByteString.Builder.writeFile fullPath (render doc)
+
+-- | Collects all the FilePath and Doc pairs and returns them concatenated
+-- in one output
+withTestWriter :: MonadIO m => (Writer m -> m a) -> m (a, Builder)
+withTestWriter action = do
+  ref <- liftIO (newIORef [])
+  result <- action $ \file doc ->
+    liftIO (modifyIORef' ref ((file, PP.unAnnotate doc) :))
+  docs <- liftIO (readIORef ref)
+  pure (result, renderOneBigFile (sortOn fst docs))
+  where
+    renderOneBigFile docs =
+      render $
+        PP.concatWith
+          (\x y -> x <> PP.line <> "---------------------" <> PP.line <> y)
+          [ PP.vsep
+              [ PP.pretty (toText file),
+                mempty,
+                doc
+              ]
+            | (file, doc) <- docs
+          ]

test/Main.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}

test/Test/Tie/Golden.hs

@@ -0,0 +1,26 @@
+module Test.Tie.Golden (test_Golden_tests) where
+
+import Data.ByteString.Builder (toLazyByteString)
+import Paths_tie (getDataDir)
+import System.FilePath (normalise, replaceExtension, (</>))
+import Test.Tasty (TestTree)
+import Test.Tasty.Golden (findByExtension, goldenVsStringDiff)
+import Tie (generate, withTestWriter)
+
+test_Golden_tests :: IO [TestTree]
+test_Golden_tests = do
+  dataDir <- getDataDir
+  inputs <- findByExtension [".yaml"] (dataDir </> "test" </> "golden")
+  pure
+    [ goldenVsStringDiff
+        ("Test " <> input)
+        (\ref new -> ["diff", "-u", ref, new])
+        (replaceExtension input ".yaml.out")
+        ( do
+            (_, output) <- withTestWriter $ \writer ->
+              generate writer input
+            pure (toLazyByteString output)
+        )
+      | input' <- inputs,
+        let input = normalise input'
+    ]

test/Test/Tie/Operation.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Tie.Operation where
+
+import Test.Hspec (Spec, context, it, shouldBe)
+import Test.Tasty.Hspec
+import Tie.Operation (PathSegment (..), parsePath)
+
+spec_parsePath :: Spec
+spec_parsePath = do
+  it "parses /users/create" $
+    parsePath "/users/create" `shouldBe` [StaticSegment "users", StaticSegment "create"]
+  it "parses /users/{id}" $
+    parsePath "/users/{id}" `shouldBe` [StaticSegment "users", VariableSegment "id"]
+  it "parses /users/{id}/address" $
+    parsePath "/users/{id}/address" `shouldBe` [StaticSegment "users", VariableSegment "id", StaticSegment "address"]

test/golden/lists.yaml

@@ -0,0 +1,47 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Scarf
+  license:
+    name: AllRightsReserved
+servers:
+  - url: https://scarf.sh/api/v1
+paths:
+  /packages:
+    get:
+      summary: List all packages
+      operationId: listPackages
+      tags:
+        - packages
+      responses:
+        '200':
+          description: An array of packages
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Packages"
+  /packages2:
+    get:
+      summary: List all packages
+      operationId: listPackages2
+      tags:
+        - packages
+      responses:
+        '200':
+          description: An inline array of packages
+          content:
+            application/json:
+              schema:
+                type: array
+                items: 
+                  $ref: "#/components/schemas/Package"
+components:
+  schemas:
+    Package: 
+      properties: 
+        name: 
+          type: string
+    Packages:
+      type: array
+      items:
+        $ref: "#/components/schemas/Package"

test/golden/lists.yaml.out

@@ -0,0 +1,233 @@
+OpenAPI/Api.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Api where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Response
+
+import OpenAPI.Schemas.Packages
+import OpenAPI.Schemas.Package
+
+import OpenAPI.Response.ListPackages
+import OpenAPI.Response.ListPackages2
+
+data Api m = Api {
+    listPackages :: m ListPackagesResponse,
+    listPackages2 :: m ListPackages2Response
+}
+
+application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
+application run api notFound request respond =
+    case Network.Wai.pathInfo request of
+        [ "packages" ] ->
+            case Network.Wai.requestMethod request of
+                "GET" ->
+                    run request $ do
+                        response <- listPackages api  
+                        Control.Monad.IO.Class.liftIO (respond (toResponse response))
+                x ->
+                    unsupportedMethod x
+
+        [ "packages2" ] ->
+            case Network.Wai.requestMethod request of
+                "GET" ->
+                    run request $ do
+                        response <- listPackages2 api  
+                        Control.Monad.IO.Class.liftIO (respond (toResponse response))
+                x ->
+                    unsupportedMethod x
+
+        _ ->
+            notFound request respond
+    where
+        unsupportedMethod _ =
+            respond (Network.Wai.responseBuilder (toEnum 405) [] mempty)
+        invalidRequest _ =
+            respond (Network.Wai.responseBuilder (toEnum 401) [] mempty)
+---------------------
+OpenAPI/Response.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+class ToResponse a where
+    toResponse :: a -> Network.Wai.Response
+---------------------
+OpenAPI/Response/ListPackages.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response.ListPackages where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Packages
+
+data ListPackagesResponse
+    = ListPackagesResponse200 Packages
+
+instance ToResponse ListPackagesResponse where
+    toResponse (ListPackagesResponse200 x) =
+        Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
+---------------------
+OpenAPI/Response/ListPackages2.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response.ListPackages2 where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Package
+
+data ListPackages2Response
+    = ListPackages2Response200 [ Package ]
+
+instance ToResponse ListPackages2Response where
+    toResponse (ListPackages2Response200 x) =
+        Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
+---------------------
+OpenAPI/Schemas/Package.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Package where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+
+
+newtype Package = Package
+    {
+        name :: Data.Maybe.Maybe (Data.Text.Text)
+    }
+
+instance Data.Aeson.ToJSON Package where
+    toJSON Package {..} = Data.Aeson.object
+        [
+            "name" Data.Aeson..= name
+        ]
+
+instance Data.Aeson.FromJSON Package where
+    parseJSON = Data.Aeson.withObject "Package" $ \o ->
+        Package
+            <$> o Data.Aeson..:? "name"
+---------------------
+OpenAPI/Schemas/Packages.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Packages where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Package
+
+
+---------------------
+open-api.cabal
+
+cabal-version: 3.0
+name: open-api
+version: 0.1.0.0
+library
+  build-depends:
+    , aeson
+    , attoparsec
+    , base
+    , ghc-prim
+    , http-api-data
+    , http-types
+    , text
+    , wai
+  exposed-modules:
+    OpenAPI.Api
+    OpenAPI.Response
+    OpenAPI.Response.ListPackages
+    OpenAPI.Response.ListPackages2
+    OpenAPI.Schemas.Package
+    OpenAPI.Schemas.Packages

test/golden/oneof.yaml

@@ -0,0 +1,32 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: Scarf
+  license:
+    name: AllRightsReserved
+servers:
+  - url: https://scarf.sh/api/v1
+paths:
+  /packages:
+    get:
+      summary: List all packages
+      operationId: listPackages
+      tags:
+        - packages
+      responses:
+        '200':
+          description: An array of packages
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Packages"
+components:
+  schemas:
+    Package: 
+      properties: 
+        name: 
+          type: string
+    Packages:
+      oneOf:
+        - $ref: "#/components/schemas/Package"
+        - $ref: "#/components/schemas/Package"

test/golden/oneof.yaml.out

@@ -0,0 +1,201 @@
+OpenAPI/Api.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Api where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Response
+
+import OpenAPI.Schemas.Packages
+
+import OpenAPI.Response.ListPackages
+
+data Api m = Api {
+    listPackages :: m ListPackagesResponse
+}
+
+application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
+application run api notFound request respond =
+    case Network.Wai.pathInfo request of
+        [ "packages" ] ->
+            case Network.Wai.requestMethod request of
+                "GET" ->
+                    run request $ do
+                        response <- listPackages api  
+                        Control.Monad.IO.Class.liftIO (respond (toResponse response))
+                x ->
+                    unsupportedMethod x
+
+        _ ->
+            notFound request respond
+    where
+        unsupportedMethod _ =
+            respond (Network.Wai.responseBuilder (toEnum 405) [] mempty)
+        invalidRequest _ =
+            respond (Network.Wai.responseBuilder (toEnum 401) [] mempty)
+---------------------
+OpenAPI/Response.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+class ToResponse a where
+    toResponse :: a -> Network.Wai.Response
+---------------------
+OpenAPI/Response/ListPackages.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response.ListPackages where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Packages
+
+data ListPackagesResponse
+    = ListPackagesResponse200 Packages
+
+instance ToResponse ListPackagesResponse where
+    toResponse (ListPackagesResponse200 x) =
+        Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
+---------------------
+OpenAPI/Schemas/Package.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Package where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+
+
+newtype Package = Package
+    {
+        name :: Data.Maybe.Maybe (Data.Text.Text)
+    }
+
+instance Data.Aeson.ToJSON Package where
+    toJSON Package {..} = Data.Aeson.object
+        [
+            "name" Data.Aeson..= name
+        ]
+
+instance Data.Aeson.FromJSON Package where
+    parseJSON = Data.Aeson.withObject "Package" $ \o ->
+        Package
+            <$> o Data.Aeson..:? "name"
+---------------------
+OpenAPI/Schemas/Packages.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Packages where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Package
+
+data Packages
+    = PackagesPackage Package
+    | PackagesPackage Package
+
+instance Data.Aeson.ToJSON Packages where
+    toJSON (PackagesPackage x) = Data.Aeson.toJSON x
+    toJSON (PackagesPackage x) = Data.Aeson.toJSON x
+
+instance Data.Aeson.FromJSON Packages where
+    parseJSON x =
+        (PackagesPackage <$> Data.Aeson.parseJSON x) Control.Applicative.<|>
+        (PackagesPackage <$> Data.Aeson.parseJSON x)
+---------------------
+open-api.cabal
+
+cabal-version: 3.0
+name: open-api
+version: 0.1.0.0
+library
+  build-depends:
+    , aeson
+    , attoparsec
+    , base
+    , ghc-prim
+    , http-api-data
+    , http-types
+    , text
+    , wai
+  exposed-modules:
+    OpenAPI.Api
+    OpenAPI.Response
+    OpenAPI.Response.ListPackages
+    OpenAPI.Schemas.Package
+    OpenAPI.Schemas.Packages

test/golden/test1.yaml

@@ -0,0 +1,145 @@
+openapi: "3.0.0"
+info:
+  version: 1.0.0
+  title: simple_violation_bool
+  license:
+    name: MIT
+  description: |
+    Simple violation in simple_violation_bool module
+servers:
+  - url: https://swagger.io/specification/
+paths:
+  /users/{id}/create/{name}:
+    parameters:
+      - in: path
+        name: id
+        schema: 
+          type: integer
+        required: true
+      - in: path
+        name: name
+        schema: 
+          type: string
+        required: true
+    post:
+      operationId: getUsers
+      summary: Adds a new user
+      requestBody:
+        content:
+          application/json:
+            schema:      # Request body contents
+              $ref: "#/components/schemas/NISE"
+      responses:
+        '200':
+          description: xxxx
+          content: 
+            application/json:
+              schema:      # Request body contents
+                $ref: "#/components/schemas/Vehicle"
+components:
+  schemas:
+    Vehicle:
+      type: object
+      required:
+        - id
+        - type
+      properties:
+        id:
+          type: integer
+        type:
+          type: string
+        model:
+          type: string
+        name:
+          type: string
+        
+    Car:
+      allOf:
+        - $ref: "#/components/schemas/Vehicle"
+        - type: object
+          properties:
+            type:
+              enum:
+                - car
+            has_4_wheel_drive:
+              type: boolean
+    
+    Plane:
+      anyOf:
+        - $ref: "#/components/schemas/Vehicle"
+        - type: object
+          properties:
+            type:
+              enum:
+                - plane
+            car: 
+              $ref: "#/components/schemas/Car"              
+            has_reactor:
+              type: boolean
+            nb_passengers:
+              type: integer
+        
+    Error:
+      required:
+        - code
+        - message
+      properties:
+        code:
+          type: integer
+          format: int32
+        message:
+          type: string
+  
+    PackageId: 
+      oneOf: 
+        - $ref: "#/components/schemas/Plane"
+        - $ref: "#/components/schemas/Car"
+        - type: integer            
+        - properties: 
+            name: 
+              type: string
+
+    NISE:
+      type: object
+      title: The Root Schema
+      required:
+        - description
+        - id
+        - name
+        - ports
+      properties:
+        description:
+          $ref: "#/components/schemas/PackageId"
+        id:
+          type: integer
+          title: The Id Schema
+          default: 0
+          format: int64
+          schema:
+            $ref: './violation_schema.yaml#/NISE'
+        name:
+          type: string
+          title: The Name Schema
+          schema:
+            $ref: './violation_schema.yaml#/NISE'
+        ports:
+          type: array
+          title: The Ports Schema
+          schema:
+            $ref: './violation_schema.yaml#/NISE'
+          items:
+            type: integer
+            title: The items Schema
+            default: 0
+            schema:
+              $ref: './violation_schema.yaml#/NISE'
+        value:
+          type: object
+          title: The Value Schema
+          properties: 
+            name: 
+              type: string
+          schema:
+            $ref: './violation_schema.yaml#/NISE'
+
+

test/golden/test1.yaml.out

@@ -0,0 +1,427 @@
+OpenAPI/Api.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Api where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Response
+
+import OpenAPI.Schemas.NISE
+import OpenAPI.Schemas.Vehicle
+
+import OpenAPI.Response.GetUsers
+
+data Api m = Api {
+    getUsers :: GHC.Types.Int -> Data.Text.Text -> NISE -> m GetUsersResponse
+}
+
+application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
+application run api notFound request respond =
+    case Network.Wai.pathInfo request of
+        [ "users", id, "create", name ] ->
+            case Web.HttpApiData.parseUrlPiece id of
+                Left _ -> invalidRequest "id"
+                Right id ->
+                    case Web.HttpApiData.parseUrlPiece name of
+                        Left _ -> invalidRequest "name"
+                        Right name ->
+                            case Network.Wai.requestMethod request of
+                                "POST" ->
+                                    do result <- Data.Attoparsec.ByteString.parseWith (Network.Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
+                                       case Data.Attoparsec.ByteString.eitherResult result of
+                                           Left _err -> undefined
+                                           Right bodyValue ->
+                                               case Data.Aeson.Types.parseEither Data.Aeson.parseJSON bodyValue of
+                                                   Left _err -> undefined
+                                                   Right body ->
+                                                       run request $ do
+                                                           response <- getUsers api id name body
+                                                           Control.Monad.IO.Class.liftIO (respond (toResponse response))
+                                x ->
+                                    unsupportedMethod x
+
+        _ ->
+            notFound request respond
+    where
+        unsupportedMethod _ =
+            respond (Network.Wai.responseBuilder (toEnum 405) [] mempty)
+        invalidRequest _ =
+            respond (Network.Wai.responseBuilder (toEnum 401) [] mempty)
+---------------------
+OpenAPI/Response.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+class ToResponse a where
+    toResponse :: a -> Network.Wai.Response
+---------------------
+OpenAPI/Response/GetUsers.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Response.GetUsers where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.NISE
+import OpenAPI.Schemas.Vehicle
+
+data GetUsersResponse
+    = GetUsersResponse200 Vehicle
+
+instance ToResponse GetUsersResponse where
+    toResponse (GetUsersResponse200 x) =
+        Network.Wai.responseBuilder (toEnum 200) [(Network.HTTP.Types.hContentType, "application/json")] (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
+---------------------
+OpenAPI/Schemas/Car.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Car where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Vehicle
+
+data Car = Car
+    {
+        has_4_wheel_drive :: Data.Maybe.Maybe (GHC.Types.Bool),
+        id :: GHC.Types.Int,
+        model :: Data.Maybe.Maybe (Data.Text.Text),
+        name :: Data.Maybe.Maybe (Data.Text.Text),
+        type' :: Data.Text.Text
+    }
+
+instance Data.Aeson.ToJSON Car where
+    toJSON Car {..} = Data.Aeson.object
+        [
+            "has_4_wheel_drive" Data.Aeson..= has_4_wheel_drive,
+            "id" Data.Aeson..= id,
+            "model" Data.Aeson..= model,
+            "name" Data.Aeson..= name,
+            "type" Data.Aeson..= type'
+        ]
+
+instance Data.Aeson.FromJSON Car where
+    parseJSON = Data.Aeson.withObject "Car" $ \o ->
+        Car
+            <$> o Data.Aeson..:? "has_4_wheel_drive"
+            <*> o Data.Aeson..: "id"
+            <*> o Data.Aeson..:? "model"
+            <*> o Data.Aeson..:? "name"
+            <*> o Data.Aeson..: "type"
+---------------------
+OpenAPI/Schemas/NISE.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.NISE where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.PackageId
+
+newtype NISEValue = NISEValue
+    {
+        name :: Data.Maybe.Maybe (Data.Text.Text)
+    }
+
+instance Data.Aeson.ToJSON NISEValue where
+    toJSON NISEValue {..} = Data.Aeson.object
+        [
+            "name" Data.Aeson..= name
+        ]
+
+instance Data.Aeson.FromJSON NISEValue where
+    parseJSON = Data.Aeson.withObject "NISEValue" $ \o ->
+        NISEValue
+            <$> o Data.Aeson..:? "name"
+
+data NISE = NISE
+    {
+        description :: PackageId,
+        id :: GHC.Types.Int,
+        name :: Data.Text.Text,
+        ports :: [ GHC.Types.Int ],
+        value :: Data.Maybe.Maybe (NISEValue)
+    }
+
+instance Data.Aeson.ToJSON NISE where
+    toJSON NISE {..} = Data.Aeson.object
+        [
+            "description" Data.Aeson..= description,
+            "id" Data.Aeson..= id,
+            "name" Data.Aeson..= name,
+            "ports" Data.Aeson..= ports,
+            "value" Data.Aeson..= value
+        ]
+
+instance Data.Aeson.FromJSON NISE where
+    parseJSON = Data.Aeson.withObject "NISE" $ \o ->
+        NISE
+            <$> o Data.Aeson..: "description"
+            <*> o Data.Aeson..: "id"
+            <*> o Data.Aeson..: "name"
+            <*> o Data.Aeson..: "ports"
+            <*> o Data.Aeson..:? "value"
+---------------------
+OpenAPI/Schemas/PackageId.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.PackageId where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Car
+import OpenAPI.Schemas.Plane
+
+newtype PackageIdOneOf4 = PackageIdOneOf4
+    {
+        name :: Data.Maybe.Maybe (Data.Text.Text)
+    }
+
+instance Data.Aeson.ToJSON PackageIdOneOf4 where
+    toJSON PackageIdOneOf4 {..} = Data.Aeson.object
+        [
+            "name" Data.Aeson..= name
+        ]
+
+instance Data.Aeson.FromJSON PackageIdOneOf4 where
+    parseJSON = Data.Aeson.withObject "PackageIdOneOf4" $ \o ->
+        PackageIdOneOf4
+            <$> o Data.Aeson..:? "name"
+
+data PackageId
+    = PackageIdPlane Plane
+    | PackageIdCar Car
+    | PackageIdPackageIdOneOf3 GHC.Types.Int
+    | PackageIdPackageIdOneOf4 PackageIdOneOf4
+
+instance Data.Aeson.ToJSON PackageId where
+    toJSON (PackageIdPlane x) = Data.Aeson.toJSON x
+    toJSON (PackageIdCar x) = Data.Aeson.toJSON x
+    toJSON (PackageIdPackageIdOneOf3 x) = Data.Aeson.toJSON x
+    toJSON (PackageIdPackageIdOneOf4 x) = Data.Aeson.toJSON x
+
+instance Data.Aeson.FromJSON PackageId where
+    parseJSON x =
+        (PackageIdPlane <$> Data.Aeson.parseJSON x) Control.Applicative.<|>
+        (PackageIdCar <$> Data.Aeson.parseJSON x) Control.Applicative.<|>
+        (PackageIdPackageIdOneOf3 <$> Data.Aeson.parseJSON x) Control.Applicative.<|>
+        (PackageIdPackageIdOneOf4 <$> Data.Aeson.parseJSON x)
+---------------------
+OpenAPI/Schemas/Plane.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Plane where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+import OpenAPI.Schemas.Car
+import OpenAPI.Schemas.Vehicle
+
+data Plane = Plane
+    {
+        car :: Data.Maybe.Maybe (Car),
+        has_reactor :: Data.Maybe.Maybe (GHC.Types.Bool),
+        id :: Data.Maybe.Maybe (GHC.Types.Int),
+        model :: Data.Maybe.Maybe (Data.Text.Text),
+        name :: Data.Maybe.Maybe (Data.Text.Text),
+        nb_passengers :: Data.Maybe.Maybe (GHC.Types.Int),
+        type' :: Data.Maybe.Maybe (Data.Text.Text)
+    }
+
+instance Data.Aeson.ToJSON Plane where
+    toJSON Plane {..} = Data.Aeson.object
+        [
+            "car" Data.Aeson..= car,
+            "has_reactor" Data.Aeson..= has_reactor,
+            "id" Data.Aeson..= id,
+            "model" Data.Aeson..= model,
+            "name" Data.Aeson..= name,
+            "nb_passengers" Data.Aeson..= nb_passengers,
+            "type" Data.Aeson..= type'
+        ]
+
+instance Data.Aeson.FromJSON Plane where
+    parseJSON = Data.Aeson.withObject "Plane" $ \o ->
+        Plane
+            <$> o Data.Aeson..:? "car"
+            <*> o Data.Aeson..:? "has_reactor"
+            <*> o Data.Aeson..:? "id"
+            <*> o Data.Aeson..:? "model"
+            <*> o Data.Aeson..:? "name"
+            <*> o Data.Aeson..:? "nb_passengers"
+            <*> o Data.Aeson..:? "type"
+---------------------
+OpenAPI/Schemas/Vehicle.hs
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module OpenAPI.Schemas.Vehicle where
+
+import qualified Control.Applicative
+import qualified Control.Monad.IO.Class
+import qualified Data.Aeson
+import qualified Data.Aeson.Parser
+import qualified Data.Aeson.Types
+import qualified Data.Attoparsec.ByteString
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified GHC.Types
+import qualified Network.HTTP.Types
+import qualified Network.Wai
+import qualified Web.HttpApiData
+
+
+
+data Vehicle = Vehicle
+    {
+        id :: GHC.Types.Int,
+        model :: Data.Maybe.Maybe (Data.Text.Text),
+        name :: Data.Maybe.Maybe (Data.Text.Text),
+        type' :: Data.Text.Text
+    }
+
+instance Data.Aeson.ToJSON Vehicle where
+    toJSON Vehicle {..} = Data.Aeson.object
+        [
+            "id" Data.Aeson..= id,
+            "model" Data.Aeson..= model,
+            "name" Data.Aeson..= name,
+            "type" Data.Aeson..= type'
+        ]
+
+instance Data.Aeson.FromJSON Vehicle where
+    parseJSON = Data.Aeson.withObject "Vehicle" $ \o ->
+        Vehicle
+            <$> o Data.Aeson..: "id"
+            <*> o Data.Aeson..:? "model"
+            <*> o Data.Aeson..:? "name"
+            <*> o Data.Aeson..: "type"
+---------------------
+open-api.cabal
+
+cabal-version: 3.0
+name: open-api
+version: 0.1.0.0
+library
+  build-depends:
+    , aeson
+    , attoparsec
+    , base
+    , ghc-prim
+    , http-api-data
+    , http-types
+    , text
+    , wai
+  exposed-modules:
+    OpenAPI.Api
+    OpenAPI.Response
+    OpenAPI.Response.GetUsers
+    OpenAPI.Schemas.Car
+    OpenAPI.Schemas.NISE
+    OpenAPI.Schemas.PackageId
+    OpenAPI.Schemas.Plane
+    OpenAPI.Schemas.Vehicle

tie.cabal

@@ -0,0 +1,113 @@
+cabal-version:      3.6
+name:               tie
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+
+-- The package author(s).
+-- author:
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+-- maintainer:
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+data-files: 
+  test/golden/**/*.yaml
+  test/golden/**/*.out
+
+library
+    exposed-modules:  Tie 
+                      Tie.Resolve
+                      Tie.Type
+                      Tie.Operation
+                      Tie.Codegen.Imports
+                      Tie.Codegen.Operation
+                      Tie.Codegen.Response
+                      Tie.Codegen.Schema
+                      Tie.Name
+                      Tie.Codegen.Cabal
+                      Tie.Writer
+
+    -- Modules included in this library but not exported.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    aeson, 
+                      base,
+                      bytestring >= 0.11.2.0,
+                      containers,
+                      text,
+                      directory,
+                      filepath,
+                      lens,
+                      mtl,
+                      openapi3,
+                      unordered-containers,
+                      insert-ordered-containers,
+                      prettyprinter,
+                      yaml,
+                      relude
+
+    mixins:
+        base hiding (Prelude),
+        relude (Relude as Prelude),
+        relude
+
+    hs-source-dirs:   src
+    default-language: Haskell2010
+
+test-suite tie-tests
+  type:               exitcode-stdio-1.0
+  main-is:            Main.hs
+
+  autogen-modules: 
+    Paths_tie
+
+  other-modules:
+    Paths_tie
+
+  other-modules:
+    Test.Tie.Golden
+    Test.Tie.Operation
+
+  build-depends:
+    , aeson
+    , base
+    , bytestring
+    , containers
+    , filepath
+    , hspec
+    , tasty-hspec
+    , tasty
+    , tasty-golden
+    , openapi3
+    , tasty-hunit
+    , tie
+    , text
+    , prettyprinter
+    , relude
+    , insert-ordered-containers
+    , yaml
+
+  mixins:
+    base hiding (Prelude),
+    relude (Relude as Prelude),
+    relude
+
+  build-tool-depends: tasty-discover:tasty-discover
+  hs-source-dirs:     test