Make compile cleanly with stack --pedantic

src/Data/Swagger/Internal.hs

@@ -458,7 +458,7 @@ deriving instance Show (SwaggerType t)
 swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
 swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
 
-swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
+swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
 swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
 
 swaggerCommonTypes :: [SwaggerType k]
@@ -605,7 +605,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
   , _paramSchemaMultipleOf :: Maybe Scientific
   } deriving (Eq, Show, Generic, Typeable)
 
-deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
+deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
 
 data Xml = Xml
   { -- | Replaces the name of the element/attribute used for the described schema property.

src/Data/Swagger/Internal/AesonUtils.hs

@@ -101,8 +101,7 @@ instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just
 -- * possible to merge sub-object
 sopSwaggerGenericToJSON
     :: forall a xs.
-        ( Generic a
-        , HasDatatypeInfo a
+        ( HasDatatypeInfo a
         , HasSwaggerAesonOptions a
         , All2 ToJSON (Code a)
         , All2 Eq (Code a)
@@ -190,8 +189,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
 
 sopSwaggerGenericParseJSON
     :: forall a xs.
-        ( Generic a
-        , HasDatatypeInfo a
+        ( HasDatatypeInfo a
         , HasSwaggerAesonOptions a
         , All2 FromJSON (Code a)
         , All2 Eq (Code a)
@@ -270,8 +268,7 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
 
 sopSwaggerGenericToEncoding
     :: forall a xs.
-        ( Generic a
-        , HasDatatypeInfo a
+        ( HasDatatypeInfo a
         , HasSwaggerAesonOptions a
         , All2 ToJSON (Code a)
         , All2 Eq (Code a)

src/Data/Swagger/Internal/ParamSchema.hs

@@ -9,6 +9,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+#if __GLASGOW_HASKELL__ >= 800
+-- Generic a is redundant in  ToParamSchema a default imple
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+#endif
 #include "overlapping-compat.h"
 module Data.Swagger.Internal.ParamSchema where
 

src/Data/Swagger/Internal/Schema.hs

@@ -13,6 +13,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+#if __GLASGOW_HASKELL__ >= 800
+-- Few generics related redundant constraints
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+#endif
 #include "overlapping-compat.h"
 module Data.Swagger.Internal.Schema where
 
@@ -22,20 +26,16 @@ import Prelude.Compat
 import Control.Lens
 import Data.Data.Lens (template)
 
-import Control.Applicative
 import Control.Monad
 import Control.Monad.Writer
 import Data.Aeson
-import qualified Data.Aeson.Types as Aeson
 import Data.Char
 import Data.Data (Data)
 import Data.Foldable (traverse_)
-import Data.Function (on)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import           "unordered-containers" Data.HashSet (HashSet)
 import qualified "unordered-containers" Data.HashSet as HashSet
-import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Int
 import Data.IntSet (IntSet)
@@ -318,11 +318,11 @@ sketchSchema = sketch . toJSON
     sketch js@(Bool _) = go js
     sketch js = go js & example ?~ js
 
-    go Null          = mempty & type_ .~ SwaggerNull
-    go js@(Bool _)   = mempty & type_ .~ SwaggerBoolean
-    go js@(String s) = mempty & type_   .~ SwaggerString
-    go js@(Number n) = mempty & type_ .~ SwaggerNumber
-    go js@(Array xs) = mempty
+    go Null       = mempty & type_ .~ SwaggerNull
+    go (Bool _)   = mempty & type_ .~ SwaggerBoolean
+    go (String _) = mempty & type_   .~ SwaggerString
+    go (Number _) = mempty & type_ .~ SwaggerNumber
+    go (Array xs) = mempty
       & type_   .~ SwaggerArray
       & items ?~ case ischema of
           Just s -> SwaggerItemsObject (Inline s)
@@ -332,9 +332,9 @@ sketchSchema = sketch . toJSON
         allSame = and ((zipWith (==)) ys (tail ys))
 
         ischema = case ys of
-          (z:zs) | allSame -> Just z
-          _ -> Nothing
-    go js@(Object o) = mempty
+          (z:_) | allSame -> Just z
+          _               -> Nothing
+    go (Object o) = mempty
       & type_         .~ SwaggerObject
       & required      .~ HashMap.keys o
       & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
@@ -649,7 +649,7 @@ gdeclareSchemaRef opts proxy = do
       return $ Ref (Reference name)
     _ -> Inline <$> gdeclareSchema opts proxy
 
-appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
+appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
 appendItem x Nothing = Just (SwaggerItemsArray [x])
 appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
 appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

src/Data/Swagger/Internal/Schema/Validation.hs

@@ -22,15 +22,13 @@ module Data.Swagger.Internal.Schema.Validation where
 
 import Control.Applicative
 import Control.Lens
-import Control.Lens.TH
 import Control.Monad (when)
 
 import Data.Aeson hiding (Result)
 import Data.Foldable (traverse_, for_, sequenceA_)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import qualified "unordered-containers" Data.HashSet as HashSet
-import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Monoid
 import Data.Proxy
@@ -61,11 +59,12 @@ validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
 -- For validation without patterns see @'validateToJSON'@.
 validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>
   (Pattern -> Text -> Bool) -> a -> [ValidationError]
-validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of
+validateToJSONWithPatternChecker checker x =
+  case runValidation (validateWithSchema js) cfg sch of
     Failed xs -> xs
     Passed _  -> mempty
   where
-    (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
+    (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
     js = toJSON x
     cfg = defaultConfig
             { configPatternChecker = checker
@@ -95,7 +94,7 @@ instance Alternative Result where
 instance Monad Result where
   return = pure
   Passed x >>=  f = f x
-  Failed xs >>= f = Failed xs
+  Failed xs >>= _ = Failed xs
 
 -- | Validation configuration.
 data Config = Config
@@ -140,7 +139,7 @@ instance Choice Validation where
 
 instance Monad (Validation s) where
   return = pure
-  Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
+  Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
   (>>) = (*>)
 
 withConfig :: (Config -> Validation s a) -> Validation s a
@@ -160,8 +159,8 @@ valid = pure ()
 -- | Validate schema's property given a lens into that property
 -- and property checker.
 check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
-check l g = withSchema $ \schema ->
-  case schema ^. l of
+check l g = withSchema $ \sch ->
+  case sch ^. l of
     Nothing -> valid
     Just x  -> g x
 
@@ -181,7 +180,7 @@ withRef (Reference ref) f = withConfig $ \cfg ->
     Just s  -> f s
 
 validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
-validateWithSchemaRef (Ref ref)  js = withRef ref $ \schema -> sub schema (validateWithSchema js)
+validateWithSchemaRef (Ref ref)  js = withRef ref $ \sch -> sub sch (validateWithSchema js)
 validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
 
 -- | Validate JSON @'Value'@ with Swagger @'Schema'@.
@@ -203,9 +202,9 @@ validateInteger n = do
   validateNumber n
 
 validateNumber :: Scientific -> Validation (ParamSchema t) ()
-validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
-  let exMax = Just True == schema ^. exclusiveMaximum
-      exMin = Just True == schema ^. exclusiveMinimum
+validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
+  let exMax = Just True == sch ^. exclusiveMaximum
+      exMin = Just True == sch ^. exclusiveMinimum
 
   check maximum_ $ \m ->
     when (if exMax then (n >= m) else (n > m)) $
@@ -262,8 +261,8 @@ validateArray xs = do
     allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
 
 validateObject :: HashMap Text Value -> Validation Schema ()
-validateObject o = withSchema $ \schema ->
-  case schema ^. discriminator of
+validateObject o = withSchema $ \sch ->
+  case sch ^. discriminator of
     Just pname -> case fromJSON <$> HashMap.lookup pname o of
       Just (Success ref) -> validateWithSchemaRef ref (Object o)
       Just (Error msg)   -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
@@ -282,17 +281,17 @@ validateObject o = withSchema $ \schema ->
   where
     size = fromIntegral (HashMap.size o)
 
-    validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
-    validateReq name =
-      when (not (HashMap.member name o)) $
-        invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
+    validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
+    validateReq n =
+      when (not (HashMap.member n o)) $
+        invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
 
-    validateProps = withSchema $ \schema -> do
+    validateProps = withSchema $ \sch -> do
       for_ (HashMap.toList o) $ \(k, v) ->
         case v of
-          Null | not (k `elem` (schema ^. required)) -> valid  -- null is fine for non-required property
+          Null | not (k `elem` (sch ^. required)) -> valid  -- null is fine for non-required property
           _ ->
-            case InsOrdHashMap.lookup k (schema ^. properties) of
+            case InsOrdHashMap.lookup k (sch ^. properties) of
               Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v
               Just s  -> validateWithSchemaRef s v
 
@@ -303,8 +302,8 @@ validateEnum value = do
       invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
 
 validateSchemaType :: Value -> Validation Schema ()
-validateSchemaType value = withSchema $ \schema ->
-  case (schema ^. type_, value) of
+validateSchemaType value = withSchema $ \sch ->
+  case (sch ^. type_, value) of
     (SwaggerNull,    Null)       -> valid
     (SwaggerBoolean, Bool _)     -> valid
     (SwaggerInteger, Number n)   -> sub_ paramSchema (validateInteger n)
@@ -315,8 +314,8 @@ validateSchemaType value = withSchema $ \schema ->
     (t, _) -> invalid $ "expected JSON value of type " ++ show t
 
 validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
-validateParamSchemaType value = withSchema $ \schema ->
-  case (schema ^. type_, value) of
+validateParamSchemaType value = withSchema $ \sch ->
+  case (sch ^. type_, value) of
     (SwaggerBoolean, Bool _)     -> valid
     (SwaggerInteger, Number n)   -> validateInteger n
     (SwaggerNumber,  Number n)   -> validateNumber n

src/Data/Swagger/Lens.hs

@@ -62,17 +62,17 @@ makePrisms ''Referenced
 
 _SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
 _SwaggerItemsArray
-  = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
+  = unto (\x -> SwaggerItemsArray x) {- $ \x -> case x of
       SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
       SwaggerItemsObject o      -> Left (SwaggerItemsObject o)
-      SwaggerItemsArray a       -> Right a
+      SwaggerItemsArray a       -> Right a -}
 
 _SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
 _SwaggerItemsObject
-  = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
+  = unto (\x -> SwaggerItemsObject x) {- $ \x -> case x of
       SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
       SwaggerItemsObject o      -> Right o
-      SwaggerItemsArray a       -> Left (SwaggerItemsArray a)
+      SwaggerItemsArray a       -> Left (SwaggerItemsArray a) -}
 
 _SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
 _SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

src/Data/Swagger/Operation.hs

@@ -30,23 +30,21 @@ module Data.Swagger.Operation (
   declareResponse,
 ) where
 
-import Control.Applicative
-import Control.Arrow
+import Prelude ()
+import Prelude.Compat
+
 import Control.Lens
 import Data.Data.Lens
-import qualified Data.HashMap.Strict as HashMap
-import Data.List
+import Data.List.Compat
 import Data.Maybe (mapMaybe)
 import Data.Monoid
 import qualified Data.Set as Set
-import Data.Traversable
 
 import Data.Swagger.Declare
 import Data.Swagger.Internal
 import Data.Swagger.Lens
 import Data.Swagger.Schema
 
-import           Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 
 -- $setup
@@ -187,7 +185,7 @@ setResponseForWith ops f code dres swag = swag
   where
     (defs, new) = runDeclare dres mempty
 
-    combine (Just (Ref (Reference name))) = case swag ^. responses.at name of
+    combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
       Just old -> f old new
       Nothing  -> new -- response name can't be dereferenced, replacing with new response
     combine (Just (Inline old)) = f old new

stack-ghc-8.0.yaml

@@ -1,3 +1,5 @@
 resolver: nightly-2016-05-29
 packages:
 - '.'
+extra-deps:
+  - aeson-0.11.2.1

stack-lts-2.yaml

@@ -2,7 +2,16 @@ flags: {}
 packages:
 - '.'
 extra-deps:
+- aeson-0.11.2.1
+- attoparsec-0.13.1.0
+- base-compat-0.9.1
+- fail-4.9.0.0
 - generics-sop-0.2.1.0
 - insert-ordered-containers-0.1.0.1
+- primitive-0.6.1.0
+- tagged-0.8.4
 - unordered-containers-0.2.7.0
 resolver: lts-2.22
+flags:
+  aeson:
+    old-locale: true

swagger2.cabal

@@ -40,8 +40,8 @@ library
     Data.Swagger.Internal.Utils
     Data.Swagger.Internal.AesonUtils
   build-depends:       base        >=4.7   && <4.10
-                     , base-compat >=0.6.0 && <0.10
-                     , aeson
+                     , base-compat >=0.9.1 && <0.10
+                     , aeson       >=0.11.2.1
                      , containers
                      , hashable
                      , generics-sop >=0.2 && <0.3