@@ -64,14 +64,13 @@ import GHC.Generics
6464import qualified Data.UUID.Types as UUID
6565import Type.Reflection (Typeable, typeRep)
6666
67−import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
68−import Data.OpenApi.Declare
69−import Data.OpenApi.Internal
70−import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71−import Data.OpenApi.Internal.TypeShape
72−import Data.OpenApi.Lens hiding (name, schema)
73−import qualified Data.OpenApi.Lens as Swagger
74−import Data.OpenApi.SchemaOptions
67+import Data.OpenApi.Declare
68+import Data.OpenApi.Internal
69+import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
70+import Data.OpenApi.Lens hiding (name, schema)
71+import qualified Data.OpenApi.Lens as Swagger
72+import Data.OpenApi.SchemaOptions
73+import Data.OpenApi.Internal.TypeShape
7574
7675import qualified Data.ByteString as BS
7776import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -136,7 +135,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
136135--
137136-- instance ToSchema Coord
138137-- @
139−class Typeable a => ToSchema a where
138+class ToSchema a where
140139 -- | Convert a type into an optionally named schema
141140 -- together with all used definitions.
142141 -- Note that the schema itself is included in definitions
@@ -406,8 +405,8 @@ sketchSchema = sketch . toJSON
406405 _ -> Nothing
407406 go (Object o) = mempty
408407 & type_ ?~ OpenApiObject
409− & required .~ sort (objectKeys o)
410− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
408+ & required .~ sort (HashMap.keys o)
409+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
411410
412411-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
413412-- Produced schema uses as much constraints as possible.
@@ -571,12 +570,12 @@ sketchStrictSchema = go . toJSON
571570 go js@(Object o) = mempty
572571 & type_ ?~ OpenApiObject
573572 & required .~ sort names
574− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
573+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
575574 & maxProperties ?~ fromIntegral (length names)
576575 & minProperties ?~ fromIntegral (length names)
577576 & enum_ ?~ [js]
578577 where
579− names = objectKeys o
578+ names = HashMap.keys o
580579
581580class GToSchema (f :: * -> *) where
582581 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -611,7 +610,7 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
611610instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
612611instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
613612
614−instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
613+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
615614
616615instance ToSchema a => ToSchema (Maybe a) where
617616 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -628,18 +627,12 @@ instance ToSchema UUID.UUID where
628627 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
629628 & example ?~ toJSON (UUID.toText UUID.nil)
630629
631−instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
632− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
633−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
634− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
635−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
636− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
637−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
638− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
639−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
640− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
641−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
642− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
630+instance (ToSchema a, ToSchema b) => ToSchema (a, b)
631+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
632+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
633+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
634+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
635+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
643636
644637timeSchema :: T.Text -> Schema
645638timeSchema fmt = mempty
@@ -658,7 +651,7 @@ instance ToSchema LocalTime where
658651 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
659652 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
660653
661−-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
654+-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
662655instance ToSchema ZonedTime where
663656 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
664657 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -690,7 +683,7 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
690683instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
691684
692685-- | NOTE: This schema does not account for the uniqueness of keys.
693−instance (ToSchema a) => ToSchema (IntMap a) where
686+instance ToSchema a => ToSchema (IntMap a) where
694687 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
695688
696689instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
@@ -811,13 +804,13 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.
811804 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
812805 => Proxy (map key value) -> Declare (Definitions Schema) Schema
813806declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
814− ToJSONKeyText getKey _ -> objectSchema getKey
807+ ToJSONKeyText keyToText _ -> objectSchema keyToText
815808 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
816809 where
817− objectSchema getKey = do
810+ objectSchema keyToText = do
818811 valueRef <- declareSchemaRef (Proxy :: Proxy value)
819812 let allKeys = [minBound..maxBound :: key]
820− mkPair k = (keyToText $ getKey k, valueRef)
813+ mkPair k = (keyToText k, valueRef)
821814 return $ mempty
822815 & type_ ?~ OpenApiObject
823816 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
@@ -860,7 +853,7 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
860853toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
861854
862855-- | A configurable generic @'Schema'@ creator.
863−genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
856+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
864857 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
865858genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
866859
@@ -868,24 +861,9 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
868861-- This function applied to @'defaultSchemaOptions'@
869862-- is used as the default for @'declareNamedSchema'@
870863-- when the type is an instance of @'Generic'@.
871−--
872−-- Default implementation will use the name from 'Typeable' instance, including concrete
873−-- instantioations of type variables.
874−--
875−-- For example:
876−--
877−-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878−-- Just "Either_Int_Bool"
879−genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
864+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
880865 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
881−genericDeclareNamedSchema opts _ =
882− rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
883− where
884− unspace ' ' = '_'
885− unspace x = x
886− orig = fmap unspace $ show $ typeRep @a
887− name = datatypeNameModifier opts orig
888−
866+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
889867
890868-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
891869genericNameSchema :: forall a d f.
@@ -945,13 +923,10 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
945923 case schema ^. items of
946924 Just (OpenApiItemsArray [_]) -> fieldSchema
947925 _ -> do
948− -- We have to run recordSchema instead of just using its defs,
949− -- since those can be recursive and will lead to infinite loop,
950− -- see https://github.com/biocad/openapi3/pull/37
951− NamedSchema _ schema' <- recordSchema
952− return (unnamed schema')
926+ declare defs
927+ return (unnamed schema)
953928 where
954− (_, NamedSchema _ schema) = runDeclare recordSchema mempty
929+ (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
955930 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
956931 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
957932
@@ -1114,6 +1089,49 @@ data Proxy2 a b = Proxy2
11141089
11151090data Proxy3 a b c = Proxy3
11161091
1092+-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
1093+--
1094+-- Intended usage:
1095+--
1096+-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1097+-- >>> :{
1098+-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
1099+-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
1100+-- :}
1101+--
1102+-- >>> toNamedSchema @(Foo Int) Proxy ^. name
1103+-- Just "Foo_Int"
1104+-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
1105+-- Just "Foo_Bool"
1106+-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
1107+-- Just "Foo_(Foo_Text)"
1108+class ToSchema1 (f :: * -> *) where
1109+ declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1110+
1111+ -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
1112+ -- above, however sadly GHC does not like it.
1113+ default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1114+ declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
1115+
1116+{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
1117+using 'ToSchema1' instance, like this:
1118+
1119+#if __GLASGOW_HASKELL__ >= 806
1120+>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1121+>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1122+#else
1123+> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1124+> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1125+#endif
1126+-}
1127+newtype BySchema1 f a = BySchema1 (f a)
1128+
1129+instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
1130+ declareNamedSchema _ = do
1131+ sch <- declareNamedSchema1 @f @a Proxy Proxy
1132+ let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
1133+ return $ rename (Just tName) sch
1134+
11171135{- $setup
11181136>>> import Data.OpenApi
11191137>>> import Data.Aeson (encode)
@@ -1123,4 +1141,7 @@ data Proxy3 a b c = Proxy3
11231141>>> :set -XDeriveAnyClass
11241142>>> :set -XStandaloneDeriving
11251143>>> :set -XTypeApplications
1144+#if __GLASGOW_HASKELL__ >= 806
1145+>>> :set -XDerivingVia
1146+#endif
11261147-}