git.iko.soy/typeable/swagger2
on master help sign in
Add Monoid instances
d8ca76dNickolay Kudasov
src/Data/Swagger/Internal.hs+127−6
compare with master
unifiedsplit
@@ -1,9 +1,11 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
3+{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TemplateHaskell #-}
8module Data.Swagger.Internal where
10module Data.Swagger.Internal where
9
11
@@ -16,6 +18,7 @@ import Data.HashMap.Strict (HashMap)
16import qualified Data.HashMap.Strict as HashMap
18import qualified Data.HashMap.Strict as HashMap
17import Data.Map (Map)
19import Data.Map (Map)
18import qualified Data.Map as Map
20import qualified Data.Map as Map
21+import Data.Monoid
19import Data.String (fromString)
22import Data.String (fromString)
20import Data.Text (Text)
23import Data.Text (Text)
21import qualified Data.Text as Text
24import qualified Data.Text as Text
@@ -112,7 +115,7 @@ data SwaggerInfo = SwaggerInfo
112 -- | Provides the version of the application API
115 -- | Provides the version of the application API
113 -- (not to be confused with the specification version).
116 -- (not to be confused with the specification version).
114 , swaggerInfoVersion :: Text
117 , swaggerInfoVersion :: Text
115− } deriving (Eq, Show)
118+ } deriving (Eq, Show, Generic)
116
119
117-- | Contact information for the exposed API.
120-- | Contact information for the exposed API.
118data SwaggerContact = SwaggerContact
121data SwaggerContact = SwaggerContact
@@ -154,7 +157,7 @@ data SwaggerPaths = SwaggerPaths
154 { -- | Holds the relative paths to the individual endpoints.
157 { -- | Holds the relative paths to the individual endpoints.
155 -- The path is appended to the @'swaggerBasePath'@ in order to construct the full URL.
158 -- The path is appended to the @'swaggerBasePath'@ in order to construct the full URL.
156 swaggerPathsMap :: HashMap FilePath SwaggerPathItem
159 swaggerPathsMap :: HashMap FilePath SwaggerPathItem
157− } deriving (Eq, Show)
160+ } deriving (Eq, Show, Generic)
158
161
159-- | Describes the operations available on a single path.
162-- | Describes the operations available on a single path.
160-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.
163-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.
@@ -187,7 +190,7 @@ data SwaggerPathItem = SwaggerPathItem
187 -- The list MUST NOT include duplicated parameters.
190 -- The list MUST NOT include duplicated parameters.
188 -- A unique parameter is defined by a combination of a name and location.
191 -- A unique parameter is defined by a combination of a name and location.
189 , swaggerPathItemParameters :: [SwaggerParameter]
192 , swaggerPathItemParameters :: [SwaggerParameter]
190− } deriving (Eq, Show)
193+ } deriving (Eq, Show, Generic)
191
194
192-- | Describes a single API operation on a path.
195-- | Describes a single API operation on a path.
193data SwaggerOperation = SwaggerOperation
196data SwaggerOperation = SwaggerOperation
@@ -250,7 +253,7 @@ data SwaggerOperation = SwaggerOperation
250 } deriving (Eq, Show, Generic)
253 } deriving (Eq, Show, Generic)
251
254
252newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }
255newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }
253− deriving (Eq, Show)
256+ deriving (Eq, Show, Monoid)
254
257
255-- | Describes a single operation parameter.
258-- | Describes a single operation parameter.
256-- A unique parameter is defined by a combination of a name and location.
259-- A unique parameter is defined by a combination of a name and location.
@@ -488,7 +491,7 @@ data SwaggerResponses = SwaggerResponses
488 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
491 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
489 -- Describes the expected response for those HTTP status codes.
492 -- Describes the expected response for those HTTP status codes.
490 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse
493 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse
491− } deriving (Eq, Show)
494+ } deriving (Eq, Show, Generic)
492
495
493type HttpStatusCode = Int
496type HttpStatusCode = Int
494
497
@@ -616,10 +619,127 @@ data SwaggerExternalDocs = SwaggerExternalDocs
616
619
617 -- | The URL for the target documentation.
620 -- | The URL for the target documentation.
618 , swaggerExternalDocsUrl :: URL
621 , swaggerExternalDocsUrl :: URL
619− } deriving (Eq, Show)
622+ } deriving (Eq, Show, Generic)
620
623
621newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
624newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
622
625
626+-- =======================================================================
627+-- Monoid instances
628+-- =======================================================================
629+
630+instance Monoid Swagger where
631+ mempty = genericMempty
632+ mappend = genericMappend
633+
634+instance Monoid SwaggerInfo where
635+ mempty = genericMempty
636+ mappend = genericMappend
637+
638+instance Monoid SwaggerPaths where
639+ mempty = genericMempty
640+ mappend = genericMappend
641+
642+instance Monoid SwaggerPathItem where
643+ mempty = genericMempty
644+ mappend = genericMappend
645+
646+instance Monoid SwaggerSchema where
647+ mempty = genericMempty
648+ mappend = genericMappend
649+
650+instance Monoid SwaggerSchemaCommon where
651+ mempty = genericMempty
652+ mappend = genericMappend
653+
654+instance Monoid SwaggerParameter where
655+ mempty = genericMempty
656+ mappend = genericMappend
657+
658+instance Monoid SwaggerParameterOtherSchema where
659+ mempty = genericMempty
660+ mappend = genericMappend
661+
662+instance Monoid SwaggerResponses where
663+ mempty = genericMempty
664+ mappend = genericMappend
665+
666+instance Monoid SwaggerResponse where
667+ mempty = genericMempty
668+ mappend = genericMappend
669+
670+instance Monoid SwaggerExternalDocs where
671+ mempty = genericMempty
672+ mappend = genericMappend
673+
674+instance Monoid SwaggerOperation where
675+ mempty = genericMempty
676+ mappend = genericMappend
677+
678+-- =======================================================================
679+-- SwaggerMonoid helper instances
680+-- =======================================================================
681+
682+instance SwaggerMonoid SwaggerInfo
683+instance SwaggerMonoid SwaggerPaths
684+instance SwaggerMonoid SwaggerPathItem
685+instance SwaggerMonoid SwaggerSchema
686+instance SwaggerMonoid SwaggerSchemaCommon
687+instance SwaggerMonoid SwaggerParameter
688+instance SwaggerMonoid SwaggerParameterOtherSchema
689+instance SwaggerMonoid SwaggerResponses
690+instance SwaggerMonoid SwaggerResponse
691+instance SwaggerMonoid SwaggerExternalDocs
692+instance SwaggerMonoid SwaggerOperation
693+
694+instance SwaggerMonoid SwaggerMimeList
695+deriving instance SwaggerMonoid URL
696+
697+instance SwaggerMonoid SwaggerSchemaType where
698+ swaggerMempty = SwaggerSchemaNull
699+ swaggerMappend _ y = y
700+
701+instance SwaggerMonoid SwaggerParameterType where
702+ swaggerMempty = SwaggerParamString
703+ swaggerMappend _ y = y
704+
705+instance SwaggerMonoid SwaggerParameterLocation where
706+ swaggerMempty = SwaggerParameterQuery
707+ swaggerMappend _ y = y
708+
709+instance SwaggerMonoid (HashMap Text SwaggerSchema) where
710+ swaggerMempty = HashMap.empty
711+ swaggerMappend = HashMap.unionWith mappend
712+
713+instance SwaggerMonoid (HashMap Text SwaggerParameter) where
714+ swaggerMempty = HashMap.empty
715+ swaggerMappend = HashMap.unionWith mappend
716+
717+instance SwaggerMonoid (HashMap Text SwaggerResponse) where
718+ swaggerMempty = HashMap.empty
719+ swaggerMappend = flip HashMap.union
720+
721+instance SwaggerMonoid (HashMap Text SwaggerSecurityScheme) where
722+ swaggerMempty = HashMap.empty
723+ swaggerMappend = flip HashMap.union
724+
725+instance SwaggerMonoid (HashMap FilePath SwaggerPathItem) where
726+ swaggerMempty = HashMap.empty
727+ swaggerMappend = HashMap.unionWith mappend
728+
729+instance SwaggerMonoid (HashMap HeaderName SwaggerHeader) where
730+ swaggerMempty = HashMap.empty
731+ swaggerMappend = flip HashMap.union
732+
733+instance SwaggerMonoid (HashMap HttpStatusCode SwaggerResponse) where
734+ swaggerMempty = HashMap.empty
735+ swaggerMappend = flip HashMap.union
736+
737+instance SwaggerMonoid SwaggerParameterSchema where
738+ swaggerMempty = SwaggerParameterOther swaggerMempty
739+ swaggerMappend (SwaggerParameterBody x) (SwaggerParameterBody y) = SwaggerParameterBody (swaggerMappend x y)
740+ swaggerMappend (SwaggerParameterOther x) (SwaggerParameterOther y) = SwaggerParameterOther (swaggerMappend x y)
741+ swaggerMappend _ y = y
742+
623-- =======================================================================
743-- =======================================================================
624-- TH derived ToJSON and FromJSON instances
744-- TH derived ToJSON and FromJSON instances
625-- =======================================================================
745-- =======================================================================
@@ -832,3 +952,4 @@ instance FromJSON SwaggerResponse where
832instance FromJSON SwaggerOperation where
952instance FromJSON SwaggerOperation where
833 parseJSON = genericParseJSON (jsonPrefix "swaggerOperation")
953 parseJSON = genericParseJSON (jsonPrefix "swaggerOperation")
834 `withDefaults` [ "deprecated" .= False ]
954 `withDefaults` [ "deprecated" .= False ]
955+
src/Data/Swagger/Internal/Utils.hs+51
@@ -1,4 +1,6 @@
1+{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeOperators #-}
2module Data.Swagger.Internal.Utils where
4module Data.Swagger.Internal.Utils where
3
5
4import Control.Arrow (first)
6import Control.Arrow (first)
@@ -74,3 +76,52 @@ withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
74withDefaults parser defs json@(Object _) = parser (json <+> object defs)
76withDefaults parser defs json@(Object _) = parser (json <+> object defs)
75withDefaults _ _ _ = empty
77withDefaults _ _ _ = empty
76
78
79+genericMempty :: (Generic a, GMonoid (Rep a)) => a
80+genericMempty = to gmempty
81+
82+genericMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a
83+genericMappend x y = to (gmappend (from x) (from y))
84+
85+class GMonoid f where
86+ gmempty :: f p
87+ gmappend :: f p -> f p -> f p
88+
89+instance GMonoid U1 where
90+ gmempty = U1
91+ gmappend _ _ = U1
92+
93+instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
94+ gmempty = gmempty :*: gmempty
95+ gmappend (a :*: x) (b :*: y) = gmappend a b :*: gmappend x y
96+
97+instance SwaggerMonoid a => GMonoid (K1 i a) where
98+ gmempty = K1 swaggerMempty
99+ gmappend (K1 x) (K1 y) = K1 (swaggerMappend x y)
100+
101+instance GMonoid f => GMonoid (M1 i t f) where
102+ gmempty = M1 gmempty
103+ gmappend (M1 x) (M1 y) = M1 (gmappend x y)
104+
105+class SwaggerMonoid m where
106+ swaggerMempty :: m
107+ swaggerMappend :: m -> m -> m
108+ default swaggerMempty :: Monoid m => m
109+ swaggerMempty = mempty
110+ default swaggerMappend :: Monoid m => m -> m -> m
111+ swaggerMappend = mappend
112+
113+instance SwaggerMonoid [a]
114+
115+instance SwaggerMonoid Text where
116+ swaggerMempty = mempty
117+ swaggerMappend _ y = y
118+
119+instance SwaggerMonoid (Maybe a) where
120+ swaggerMempty = Nothing
121+ swaggerMappend x Nothing = x
122+ swaggerMappend _ y = y
123+
124+instance SwaggerMonoid Bool where
125+ swaggerMempty = False
126+ swaggerMappend _ y = y
127+