Swagger schemas for arrays, dimap and comment

autodocodec-api-usage/test_resources/swagger-schema/char.json

@@ -5,6 +5,8 @@
         "title": ""
     },
     "definitions": {
-        "Char": {}
+        "Char": {
+            "type": "string"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/int.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Int": {}
+        "Int": {
+            "type": "number",
+            "description": "Int"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/int16.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Int16": {}
+        "Int16": {
+            "type": "number",
+            "description": "Int16"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/int32.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Int32": {}
+        "Int32": {
+            "type": "number",
+            "description": "Int32"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/int64.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Int64": {}
+        "Int64": {
+            "type": "number",
+            "description": "Int64"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/int8.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Int8": {}
+        "Int8": {
+            "type": "number",
+            "description": "Int8"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/lazy-text.json

@@ -5,6 +5,8 @@
         "title": ""
     },
     "definitions": {
-        "Text": {}
+        "Text": {
+            "type": "string"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/list-text.json

@@ -5,6 +5,11 @@
         "title": ""
     },
     "definitions": {
-        "[Text]": {}
+        "[Text]": {
+            "items": {
+                "type": "string"
+            },
+            "type": "array"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/string.json

@@ -5,6 +5,8 @@
         "title": ""
     },
     "definitions": {
-        "[Char]": {}
+        "[Char]": {
+            "type": "string"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/word.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Word": {}
+        "Word": {
+            "type": "number",
+            "description": "Word"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/word16.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Word16": {}
+        "Word16": {
+            "type": "number",
+            "description": "Word16"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/word32.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Word32": {}
+        "Word32": {
+            "type": "number",
+            "description": "Word32"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/word64.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Word64": {}
+        "Word64": {
+            "type": "number",
+            "description": "Word64"
+        }
     }
 }

autodocodec-api-usage/test_resources/swagger-schema/word8.json

@@ -5,6 +5,9 @@
         "title": ""
     },
     "definitions": {
-        "Word8": {}
+        "Word8": {
+            "type": "number",
+            "description": "Word8"
+        }
     }
 }

autodocodec-swagger2/autodocodec-swagger2.cabal

@@ -31,6 +31,7 @@ library
       aeson
     , autodocodec
     , base >=4.7 && <5
+    , insert-ordered-containers
     , scientific
     , swagger2
     , text

autodocodec-swagger2/package.yaml

@@ -16,6 +16,7 @@ library:
   dependencies:
   - aeson
   - autodocodec
+  - insert-ordered-containers
   - scientific
   - swagger2
   - text

autodocodec-swagger2/src/Autodocodec/Swagger.hs

@@ -1,26 +1,64 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Autodocodec.Swagger where
 
 import Autodocodec
+import Control.Monad
 import qualified Data.Aeson as JSON
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Proxy
 import Data.Scientific
-import Data.Swagger
-import Data.Swagger.Declare
+import Data.Swagger as Swagger
+import Data.Swagger.Declare as Swagger
 import Data.Text (Text)
+import Debug.Trace
 
 declareNamedSchemaViaCodec :: HasCodec value => Proxy value -> Declare (Definitions Schema) NamedSchema
 declareNamedSchemaViaCodec proxy = declareNamedSchemaVia codec proxy
 
 declareNamedSchemaVia :: JSONCodec value -> Proxy value -> Declare (Definitions Schema) NamedSchema
-declareNamedSchemaVia c Proxy = go c
+declareNamedSchemaVia c' Proxy = go c'
   where
     go :: Codec context input output -> Declare (Definitions Schema) NamedSchema
     go = \case
       BoolCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Bool)
       StringCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Text)
       NumberCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Scientific)
+      ArrayOfCodec mname c -> do
+        traceM "hello"
+        itemsSchema <- go c
+        itemsSchemaRef <- declareNamedSchemaRef itemsSchema
+        pure $
+          NamedSchema mname $
+            mempty
+              { _schemaParamSchema =
+                  mempty
+                    { _paramSchemaType = Just SwaggerArray,
+                      _paramSchemaItems = Just $ SwaggerItemsObject $ _namedSchemaSchema <$> itemsSchemaRef
+                    }
+              }
       ObjectCodec -> declareNamedSchema (Proxy :: Proxy JSON.Object)
+      MapCodec _ _ c -> go c
+      CommentCodec t c -> do
+        NamedSchema mName s <- go c
+        let desc = case _schemaDescription s of
+              Nothing -> Just t
+              Just d -> Just $ t <> "\n" <> d
+        pure $ NamedSchema mName $ s {_schemaDescription = desc}
       _ -> pure $ NamedSchema Nothing mempty -- TODO
+
+declareNamedSchemaRef :: Swagger.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)
+declareNamedSchemaRef namedSchema =
+  fmap (NamedSchema (_namedSchemaName namedSchema))
+    <$> declareSpecificSchemaRef (_namedSchemaName namedSchema) (_namedSchemaSchema namedSchema)
+
+declareSpecificSchemaRef :: Maybe Text -> Swagger.Schema -> Declare (Definitions Schema) (Referenced Schema)
+declareSpecificSchemaRef mName s =
+  case mName of
+    Nothing -> pure $ Inline s
+    Just n -> do
+      known <- looks (InsOrdHashMap.member n)
+      when (not known) $ declare $ InsOrdHashMap.singleton n s
+      pure $ Ref (Reference n)