Merge pull request #36 from GetShopTV/unit-#35

Better support for unit types

CHANGELOG.md

@@ -1,3 +1,12 @@
+* Minor changes:
+  * Change default `ToSchema` instance for unit data types (i.e. types with one nullable constructor like `data Unit = Unit`):
+    now these types are treated like sum types with only one alternative;
+  * Add generic `ToParamSchema` instance for unit data types;
+  * Add `items: []` to schema for `()` (making it a valid schema).
+
+* Fixes:
+    * `items: []` is not omitted from `Schema` JSON.
+
 1.1.1
 ---
 * Fixes:

src/Data/Swagger/Internal.hs

@@ -906,7 +906,10 @@ instance ToJSON SecurityScheme where
   toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
 
 instance ToJSON Schema where
-  toJSON = omitEmpties . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
+  toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
+    where
+      f "items" (Array _) = True
+      f _ _ = False
 
 instance ToJSON Header where
   toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
@@ -985,7 +988,10 @@ instance ToJSON (CollectionFormat t) where
   toJSON CollectionMulti = "multi"
 
 instance ToJSON (ParamSchema t) where
-  toJSON = omitEmpties . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
+  toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
+    where
+      f "items" (Array _) = True
+      f _ _ = False
 
 -- =======================================================================
 -- Manual FromJSON instances

src/Data/Swagger/Internal/ParamSchema.hs

@@ -206,6 +206,9 @@ class GToParamSchema (f :: * -> *) where
 instance GToParamSchema f => GToParamSchema (D1 d f) where
   gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
 
+instance Constructor c => GToParamSchema (C1 c U1) where
+  gtoParamSchema = genumParamSchema
+
 instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
   gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
 

src/Data/Swagger/Internal/Schema.hs

@@ -292,7 +292,9 @@ instance ToSchema a => ToSchema (Maybe a) where
 
 instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
 
-instance ToSchema ()
+instance ToSchema () where
+  declareNamedSchema _ = pure (Nothing, nullarySchema)
+
 instance (ToSchema a, ToSchema b) => ToSchema (a, b)
 instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
 instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -418,16 +420,14 @@ nullarySchema :: Schema
 nullarySchema = mempty
   & schemaType .~ SwaggerArray
   & schemaEnum ?~ [ toJSON () ]
+  & schemaItems ?~ SwaggerItemsArray []
 
 gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
 gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
 
 gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema
 gdeclareSchema opts proxy = snd <$> gdeclareNamedSchema opts proxy mempty
 
-instance GToSchema U1 where
-  gdeclareNamedSchema _ _ _ = plain nullarySchema
-
 instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
   gdeclareNamedSchema opts _ schema = do
     (_, gschema) <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
@@ -441,6 +441,9 @@ instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
 instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
   gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
 
+instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
+  gdeclareNamedSchema = gdeclareNamedSumSchema
+
 -- | Single field constructor.
 instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
   gdeclareNamedSchema opts _ s
@@ -511,16 +514,19 @@ instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
 
 instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
-  gdeclareNamedSchema opts _ s
-    | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
-    | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
-    where
-      declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
-      (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
+  gdeclareNamedSchema = gdeclareNamedSumSchema
+
+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema
+gdeclareNamedSumSchema opts proxy s
+  | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
+  | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
+  where
+    declareSumSchema = gsumToSchema opts proxy s
+    (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
 
-      toStringTag schema = mempty
-        & schemaType .~ SwaggerString
-        & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
+    toStringTag schema = mempty
+      & schemaType .~ SwaggerString
+      & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
 
 type AllNullary = All
 

src/Data/Swagger/Internal/Utils.hs

@@ -58,11 +58,14 @@ parseOneOf xs js =
   where
     ys = zip (map toJSON xs) xs
 
-omitEmpties :: Value -> Value
-omitEmpties (Object o) = Object (HashMap.filter nonEmpty o)
+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
   where
-    nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
-omitEmpties js = js
+    nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
+omitEmptiesExcept _ js = js
+
+omitEmpties :: Value -> Value
+omitEmpties = omitEmptiesExcept (\_ _ -> False)
 
 genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
 genericToJSONWithSub sub opts x =

test/Data/Swagger/ParamSchemaSpec.hs

@@ -23,6 +23,7 @@ checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
 spec :: Spec
 spec = do
   describe "Generic ToParamSchema" $ do
+    context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
     context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
     context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
     context "Unary records" $ do
@@ -32,6 +33,20 @@ spec = do
 main :: IO ()
 main = hspec spec
 
+-- ========================================================================
+-- Unit type
+-- ========================================================================
+
+data Unit = Unit deriving (Generic, ToParamSchema)
+
+unitSchemaJSON :: Value
+unitSchemaJSON = [aesonQQ|
+{
+  "type": "string",
+  "enum": ["Unit"]
+}
+|]
+
 -- ========================================================================
 -- Color (enum)
 -- ========================================================================

test/Data/Swagger/SchemaSpec.hs

@@ -404,8 +404,8 @@ data Unit = Unit deriving (Generic, ToSchema)
 unitSchemaJSON :: Value
 unitSchemaJSON = [aesonQQ|
 {
-  "type": "array",
-  "enum": [[]]
+  "type": "string",
+  "enum": ["Unit"]
 }
 |]