016e4c3 · typeable/openapi3

git.iko.soy/typeable/openapi3

Merge pull request #82 from phadej/stack-pedantic

Make compile cleanly with stack --pedantic

commit016e4c3ac394974caa6d37371d9c6e1a66d0786e authorOleg Grenrus <oleg.grenrus@iki.fi> dateFri 30 Sep 2016, 16:52 (10 years ago) parent2c26881 68e95a6

10 files changed+70−57

compare with master

unifiedsplit

src/Data/Swagger/Internal.hs+2−2 src/Data/Swagger/Internal/AesonUtils.hs+3−6 src/Data/Swagger/Internal/ParamSchema.hs+4 src/Data/Swagger/Internal/Schema.hs+13−13 src/Data/Swagger/Internal/Schema/Validation.hs+24−25 src/Data/Swagger/Lens.hs+6−2 src/Data/Swagger/Operation.hs+5−7 stack-ghc-8.0.yaml+2 stack-lts-2.yaml+9 swagger2.cabal+2−2

src/Data/Swagger/Internal.hs+2−2

@@ -458,7 +458,7 @@ deriving instance Show (SwaggerType t)

458458swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr

459459swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix

460460

461−swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType

461+swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType

462462swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs

463463

464464swaggerCommonTypes :: [SwaggerType k]

@@ -605,7 +605,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema

605605 , _paramSchemaMultipleOf :: Maybe Scientific

606606 } deriving (Eq, Show, Generic, Typeable)

607607

608−deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)

608+deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)

609609

610610data Xml = Xml

611611 { -- | Replaces the name of the element/attribute used for the described schema property.

src/Data/Swagger/Internal/AesonUtils.hs+3−6

@@ -101,8 +101,7 @@ instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just

101101-- * possible to merge sub-object

102102sopSwaggerGenericToJSON

103103 :: forall a xs.

104− ( Generic a

105− , HasDatatypeInfo a

104+ ( HasDatatypeInfo a

106105 , HasSwaggerAesonOptions a

107106 , All2 ToJSON (Code a)

108107 , All2 Eq (Code a)

@@ -190,8 +189,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

190189

191190sopSwaggerGenericParseJSON

192191 :: forall a xs.

193− ( Generic a

194− , HasDatatypeInfo a

192+ ( HasDatatypeInfo a

195193 , HasSwaggerAesonOptions a

196194 , All2 FromJSON (Code a)

197195 , All2 Eq (Code a)

@@ -270,8 +268,7 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

270268

271269sopSwaggerGenericToEncoding

272270 :: forall a xs.

273− ( Generic a

274− , HasDatatypeInfo a

271+ ( HasDatatypeInfo a

275272 , HasSwaggerAesonOptions a

276273 , All2 ToJSON (Code a)

277274 , All2 Eq (Code a)

src/Data/Swagger/Internal/ParamSchema.hs+4

@@ -9,6 +9,10 @@

99{-# LANGUAGE ScopedTypeVariables #-}

1010{-# LANGUAGE TypeOperators #-}

1111{-# LANGUAGE TypeSynonymInstances #-}

12+#if __GLASGOW_HASKELL__ >= 800

13+-- Generic a is redundant in ToParamSchema a default imple

14+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

15+#endif

1216#include "overlapping-compat.h"

1317module Data.Swagger.Internal.ParamSchema where

1418

src/Data/Swagger/Internal/Schema.hs+13−13

@@ -13,6 +13,10 @@

1313{-# LANGUAGE TypeFamilies #-}

1414{-# LANGUAGE TypeOperators #-}

1515{-# LANGUAGE TypeSynonymInstances #-}

16+#if __GLASGOW_HASKELL__ >= 800

17+-- Few generics related redundant constraints

18+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

19+#endif

1620#include "overlapping-compat.h"

1721module Data.Swagger.Internal.Schema where

1822

@@ -22,20 +26,16 @@ import Prelude.Compat

2226import Control.Lens

2327import Data.Data.Lens (template)

2428

25−import Control.Applicative

2629import Control.Monad

2730import Control.Monad.Writer

2831import Data.Aeson

29−import qualified Data.Aeson.Types as Aeson

3032import Data.Char

3133import Data.Data (Data)

3234import Data.Foldable (traverse_)

33−import Data.Function (on)

3435import Data.HashMap.Strict (HashMap)

3536import qualified Data.HashMap.Strict as HashMap

3637import "unordered-containers" Data.HashSet (HashSet)

3738import qualified "unordered-containers" Data.HashSet as HashSet

38−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

3939import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

4040import Data.Int

4141import Data.IntSet (IntSet)

@@ -318,11 +318,11 @@ sketchSchema = sketch . toJSON

318318 sketch js@(Bool _) = go js

319319 sketch js = go js & example ?~ js

320320

321− go Null = mempty & type_ .~ SwaggerNull

322− go js@(Bool _) = mempty & type_ .~ SwaggerBoolean

323− go js@(String s) = mempty & type_ .~ SwaggerString

324− go js@(Number n) = mempty & type_ .~ SwaggerNumber

325− go js@(Array xs) = mempty

321+ go Null = mempty & type_ .~ SwaggerNull

322+ go (Bool _) = mempty & type_ .~ SwaggerBoolean

323+ go (String _) = mempty & type_ .~ SwaggerString

324+ go (Number _) = mempty & type_ .~ SwaggerNumber

325+ go (Array xs) = mempty

326326 & type_ .~ SwaggerArray

327327 & items ?~ case ischema of

328328 Just s -> SwaggerItemsObject (Inline s)

@@ -332,9 +332,9 @@ sketchSchema = sketch . toJSON

332332 allSame = and ((zipWith (==)) ys (tail ys))

333333

334334 ischema = case ys of

335− (z:zs) | allSame -> Just z

336− _ -> Nothing

337− go js@(Object o) = mempty

335+ (z:_) | allSame -> Just z

336+ _ -> Nothing

337+ go (Object o) = mempty

338338 & type_ .~ SwaggerObject

339339 & required .~ HashMap.keys o

340340 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

@@ -649,7 +649,7 @@ gdeclareSchemaRef opts proxy = do

649649 return $ Ref (Reference name)

650650 _ -> Inline <$> gdeclareSchema opts proxy

651651

652−appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)

652+appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)

653653appendItem x Nothing = Just (SwaggerItemsArray [x])

654654appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

655655appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

src/Data/Swagger/Internal/Schema/Validation.hs+24−25

@@ -22,7 +22,6 @@ module Data.Swagger.Internal.Schema.Validation where

2222

2323import Control.Applicative

2424import Control.Lens

25−import Control.Lens.TH

2625import Control.Monad (when)

2726

2827import Data.Aeson hiding (Result)

@@ -30,7 +29,6 @@ import Data.Foldable (traverse_, for_, sequenceA_)

3029import Data.HashMap.Strict (HashMap)

3130import qualified Data.HashMap.Strict as HashMap

3231import qualified "unordered-containers" Data.HashSet as HashSet

33−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

3432import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

3533import Data.Monoid

3634import Data.Proxy

@@ -61,11 +59,12 @@ validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

6159-- For validation without patterns see @'validateToJSON'@.

6260validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

6361 (Pattern -> Text -> Bool) -> a -> [ValidationError]

64−validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of

62+validateToJSONWithPatternChecker checker x =

63+ case runValidation (validateWithSchema js) cfg sch of

6564 Failed xs -> xs

6665 Passed _ -> mempty

6766 where

68− (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

67+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

6968 js = toJSON x

7069 cfg = defaultConfig

7170 { configPatternChecker = checker

@@ -95,7 +94,7 @@ instance Alternative Result where

9594instance Monad Result where

9695 return = pure

9796 Passed x >>= f = f x

98− Failed xs >>= f = Failed xs

97+ Failed xs >>= _ = Failed xs

9998

10099-- | Validation configuration.

101100data Config = Config

@@ -140,7 +139,7 @@ instance Choice Validation where

140139

141140instance Monad (Validation s) where

142141 return = pure

143− Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)

142+ Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)

144143 (>>) = (*>)

145144

146145withConfig :: (Config -> Validation s a) -> Validation s a

@@ -160,8 +159,8 @@ valid = pure ()

160159-- | Validate schema's property given a lens into that property

161160-- and property checker.

162161check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

163−check l g = withSchema $ \schema ->

164− case schema ^. l of

162+check l g = withSchema $ \sch ->

163+ case sch ^. l of

165164 Nothing -> valid

166165 Just x -> g x

167166

@@ -181,7 +180,7 @@ withRef (Reference ref) f = withConfig $ \cfg ->

181180 Just s -> f s

182181

183182validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

184−validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

183+validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)

185184validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

186185

187186-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

@@ -203,9 +202,9 @@ validateInteger n = do

203202 validateNumber n

204203

205204validateNumber :: Scientific -> Validation (ParamSchema t) ()

206−validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do

207− let exMax = Just True == schema ^. exclusiveMaximum

208− exMin = Just True == schema ^. exclusiveMinimum

205+validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do

206+ let exMax = Just True == sch ^. exclusiveMaximum

207+ exMin = Just True == sch ^. exclusiveMinimum

209208

210209 check maximum_ $ \m ->

211210 when (if exMax then (n >= m) else (n > m)) $

@@ -262,8 +261,8 @@ validateArray xs = do

262261 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

263262

264263validateObject :: HashMap Text Value -> Validation Schema ()

265−validateObject o = withSchema $ \schema ->

266− case schema ^. discriminator of

264+validateObject o = withSchema $ \sch ->

265+ case sch ^. discriminator of

267266 Just pname -> case fromJSON <$> HashMap.lookup pname o of

268267 Just (Success ref) -> validateWithSchemaRef ref (Object o)

269268 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

@@ -282,17 +281,17 @@ validateObject o = withSchema $ \schema ->

282281 where

283282 size = fromIntegral (HashMap.size o)

284283

285− validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)

286− validateReq name =

287− when (not (HashMap.member name o)) $

288− invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))

284+ validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)

285+ validateReq n =

286+ when (not (HashMap.member n o)) $

287+ invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))

289288

290− validateProps = withSchema $ \schema -> do

289+ validateProps = withSchema $ \sch -> do

291290 for_ (HashMap.toList o) $ \(k, v) ->

292291 case v of

293− Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property

292+ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

294293 _ ->

295− case InsOrdHashMap.lookup k (schema ^. properties) of

294+ case InsOrdHashMap.lookup k (sch ^. properties) of

296295 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

297296 Just s -> validateWithSchemaRef s v

298297

@@ -303,8 +302,8 @@ validateEnum value = do

303302 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

304303

305304validateSchemaType :: Value -> Validation Schema ()

306−validateSchemaType value = withSchema $ \schema ->

307− case (schema ^. type_, value) of

305+validateSchemaType value = withSchema $ \sch ->

306+ case (sch ^. type_, value) of

308307 (SwaggerNull, Null) -> valid

309308 (SwaggerBoolean, Bool _) -> valid

310309 (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

@@ -315,8 +314,8 @@ validateSchemaType value = withSchema $ \schema ->

315314 (t, _) -> invalid $ "expected JSON value of type " ++ show t

316315

317316validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

318−validateParamSchemaType value = withSchema $ \schema ->

319− case (schema ^. type_, value) of

317+validateParamSchemaType value = withSchema $ \sch ->

318+ case (sch ^. type_, value) of

320319 (SwaggerBoolean, Bool _) -> valid

321320 (SwaggerInteger, Number n) -> validateInteger n

322321 (SwaggerNumber, Number n) -> validateNumber n

src/Data/Swagger/Lens.hs+6−2

@@ -62,17 +62,21 @@ makePrisms ''Referenced

6262

6363_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

6464_SwaggerItemsArray

65− = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

65+ = unto (\x -> SwaggerItemsArray x)

66+{- \x -> case x of

6667 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

6768 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

6869 SwaggerItemsArray a -> Right a

70+-}

6971

7072_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

7173_SwaggerItemsObject

72− = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

74+ = unto (\x -> SwaggerItemsObject x)

75+{- \x -> case x of

7376 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

7477 SwaggerItemsObject o -> Right o

7578 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79+-}

7680

7781_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

7882_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

src/Data/Swagger/Operation.hs+5−7

@@ -30,23 +30,21 @@ module Data.Swagger.Operation (

3030 declareResponse,

3131) where

3232

33−import Control.Applicative

34−import Control.Arrow

33+import Prelude ()

34+import Prelude.Compat

35+

3536import Control.Lens

3637import Data.Data.Lens

37−import qualified Data.HashMap.Strict as HashMap

38−import Data.List

38+import Data.List.Compat

3939import Data.Maybe (mapMaybe)

4040import Data.Monoid

4141import qualified Data.Set as Set

42−import Data.Traversable

4342

4443import Data.Swagger.Declare

4544import Data.Swagger.Internal

4645import Data.Swagger.Lens

4746import Data.Swagger.Schema

4847

49−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

5048import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

5149

5250-- $setup

@@ -187,7 +185,7 @@ setResponseForWith ops f code dres swag = swag

187185 where

188186 (defs, new) = runDeclare dres mempty

189187

190− combine (Just (Ref (Reference name))) = case swag ^. responses.at name of

188+ combine (Just (Ref (Reference n))) = case swag ^. responses.at n of

191189 Just old -> f old new

192190 Nothing -> new -- response name can't be dereferenced, replacing with new response

193191 combine (Just (Inline old)) = f old new

stack-ghc-8.0.yaml+2

@@ -1,3 +1,5 @@

11resolver: nightly-2016-05-29

22packages:

33- '.'

4+extra-deps:

5+ - aeson-0.11.2.1

stack-lts-2.yaml+9

@@ -2,7 +2,16 @@ flags: {}

22packages:

33- '.'

44extra-deps:

5+- aeson-0.11.2.1

6+- attoparsec-0.13.1.0

7+- base-compat-0.9.1

8+- fail-4.9.0.0

59- generics-sop-0.2.1.0

610- insert-ordered-containers-0.1.0.1

11+- primitive-0.6.1.0

12+- tagged-0.8.4

713- unordered-containers-0.2.7.0

814resolver: lts-2.22

15+flags:

16+ aeson:

17+ old-locale: true

swagger2.cabal+2−2

@@ -40,8 +40,8 @@ library

4040 Data.Swagger.Internal.Utils

4141 Data.Swagger.Internal.AesonUtils

4242 build-depends: base >=4.7 && <4.10

43− , base-compat >=0.6.0 && <0.10

44− , aeson

43+ , base-compat >=0.9.1 && <0.10

44+ , aeson >=0.11.2.1

4545 , containers

4646 , hashable

4747 , generics-sop >=0.2 && <0.3