@@ -0,0 +1,78 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TypeSynonymInstances #-}
8+module Data.Swagger.Generic where
9+
10+import Control.Lens
11+import Data.Aeson
12+import Data.Monoid
13+import Data.Proxy
14+import qualified Data.Text as Text
15+import GHC.Generics
16+
17+import Data.Swagger
18+import Data.Swagger.Lens
19+
20+class ToSchema a where
21+ toSchema :: proxy a -> Schema
22+ default toSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Schema
23+ toSchema = genericToSchema
24+
25+class GToSchema (f :: * -> *) where
26+ gtoSchema :: proxy f -> Schema -> Schema
27+
28+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
29+ toSchema _ = mempty
30+ { _schemaType = SchemaArray
31+ , _schemaItems = Just (SchemaItemsObject (Inline (toSchema (Proxy :: Proxy a))))
32+ }
33+
34+instance {-# OVERLAPPING #-} ToSchema String where
35+ toSchema _ = mempty { _schemaType = SchemaString }
36+
37+instance ToSchema Bool where
38+ toSchema _ = mempty { _schemaType = SchemaBoolean }
39+
40+instance ToSchema Integer where
41+ toSchema _ = mempty { _schemaType = SchemaInteger }
42+
43+instance ToSchema Int where toSchema = toSchemaBoundedIntegral
44+
45+instance ToSchema Double where
46+ toSchema _ = mempty { _schemaType = SchemaNumber }
47+
48+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
49+toSchemaBoundedIntegral _ = mempty
50+ & schemaType .~ SchemaInteger
51+ & schemaMinimum ?~ toInteger (minBound :: a)
52+ & schemaMaximum ?~ toInteger (maxBound :: a)
53+
54+toSchemaBoundedEnum :: forall a proxy. (ToJSON a, Bounded a, Enum a) => proxy a -> Schema
55+toSchemaBoundedEnum _ = mempty
56+ & schemaType .~ SchemaString
57+ & schemaEnum ?~ map toJSON [minBound..maxBound :: a]
58+
59+genericToSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => proxy a -> Schema
60+genericToSchema _ = gtoSchema (Proxy :: Proxy (Rep a)) mempty
61+
62+instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
63+ gtoSchema _ = gtoSchema (Proxy :: Proxy f) <> gtoSchema (Proxy :: Proxy g)
64+
65+-- | Single constructor data types.
66+instance GToSchema f => GToSchema (D1 d (C1 c f)) where
67+ gtoSchema _ = gtoSchema (Proxy :: Proxy f)
68+
69+-- | Record fields.
70+instance (Selector s, GToSchema f) => GToSchema (S1 s f) where
71+ gtoSchema _ = schemaProperties . at fieldName ?~ Inline fieldSchema
72+ where
73+ fieldName = Text.pack (selName (undefined :: S1 s f p))
74+ fieldSchema = gtoSchema (Proxy :: Proxy f) mempty
75+
76+instance ToSchema c => GToSchema (K1 i c) where
77+ gtoSchema _ _ = toSchema (Proxy :: Proxy c)
78+