d8ca76d · typeable/swagger2

git.iko.soy/typeable/swagger2

Add Monoid instances

commitd8ca76d8810d2ce6aaa307d8c6e8258abd3cdd2a authorNickolay Kudasov <nickolay.kudasov@gmail.com> dateSun 8 Nov 2015, 16:09 (11 years ago) parent994dad6

2 files changed+178−6

compare with master

unifiedsplit

src/Data/Swagger/Internal.hs+127−6 src/Data/Swagger/Internal/Utils.hs+51

src/Data/Swagger/Internal.hs+127−6

@@ -1,9 +1,11 @@

11{-# LANGUAGE DeriveGeneric #-}

22{-# LANGUAGE DeriveTraversable #-}

3+{-# LANGUAGE FlexibleInstances #-}

34{-# LANGUAGE GeneralizedNewtypeDeriving #-}

45{-# LANGUAGE OverloadedStrings #-}

56{-# LANGUAGE RecordWildCards #-}

67{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

79{-# LANGUAGE TemplateHaskell #-}

810module Data.Swagger.Internal where

911

@@ -16,6 +18,7 @@ import Data.HashMap.Strict (HashMap)

1618import qualified Data.HashMap.Strict as HashMap

1719import Data.Map (Map)

1820import qualified Data.Map as Map

21+import Data.Monoid

1922import Data.String (fromString)

2023import Data.Text (Text)

2124import qualified Data.Text as Text

@@ -112,7 +115,7 @@ data SwaggerInfo = SwaggerInfo

112115 -- | Provides the version of the application API

113116 -- (not to be confused with the specification version).

114117 , swaggerInfoVersion :: Text

115− } deriving (Eq, Show)

118+ } deriving (Eq, Show, Generic)

116119

117120-- | Contact information for the exposed API.

118121data SwaggerContact = SwaggerContact

@@ -154,7 +157,7 @@ data SwaggerPaths = SwaggerPaths

154157 { -- | Holds the relative paths to the individual endpoints.

155158 -- The path is appended to the @'swaggerBasePath'@ in order to construct the full URL.

156159 swaggerPathsMap :: HashMap FilePath SwaggerPathItem

157− } deriving (Eq, Show)

160+ } deriving (Eq, Show, Generic)

158161

159162-- | Describes the operations available on a single path.

160163-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.

@@ -187,7 +190,7 @@ data SwaggerPathItem = SwaggerPathItem

187190 -- The list MUST NOT include duplicated parameters.

188191 -- A unique parameter is defined by a combination of a name and location.

189192 , swaggerPathItemParameters :: [SwaggerParameter]

190− } deriving (Eq, Show)

193+ } deriving (Eq, Show, Generic)

191194

192195-- | Describes a single API operation on a path.

193196data SwaggerOperation = SwaggerOperation

@@ -250,7 +253,7 @@ data SwaggerOperation = SwaggerOperation

250253 } deriving (Eq, Show, Generic)

251254

252255newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }

253− deriving (Eq, Show)

256+ deriving (Eq, Show, Monoid)

254257

255258-- | Describes a single operation parameter.

256259-- A unique parameter is defined by a combination of a name and location.

@@ -488,7 +491,7 @@ data SwaggerResponses = SwaggerResponses

488491 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).

489492 -- Describes the expected response for those HTTP status codes.

490493 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse

491− } deriving (Eq, Show)

494+ } deriving (Eq, Show, Generic)

492495

493496type HttpStatusCode = Int

494497

@@ -616,10 +619,127 @@ data SwaggerExternalDocs = SwaggerExternalDocs

616619

617620 -- | The URL for the target documentation.

618621 , swaggerExternalDocsUrl :: URL

619− } deriving (Eq, Show)

622+ } deriving (Eq, Show, Generic)

620623

621624newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)

622625

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+

623743-- =======================================================================

624744-- TH derived ToJSON and FromJSON instances

625745-- =======================================================================

@@ -832,3 +952,4 @@ instance FromJSON SwaggerResponse where

832952instance FromJSON SwaggerOperation where

833953 parseJSON = genericParseJSON (jsonPrefix "swaggerOperation")

834954 `withDefaults` [ "deprecated" .= False ]

955+

src/Data/Swagger/Internal/Utils.hs+51

@@ -1,4 +1,6 @@

1+{-# LANGUAGE DefaultSignatures #-}

12{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE TypeOperators #-}

24module Data.Swagger.Internal.Utils where

46import Control.Arrow (first)

@@ -74,3 +76,52 @@ withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a

7476withDefaults parser defs json@(Object _) = parser (json <+> object defs)

7577withDefaults _ _ _ = empty

7678

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+