#87 add instance for time of day

src/Data/Swagger/Internal/ParamSchema.hs

@@ -193,6 +193,12 @@ timeParamSchema fmt = mempty
 instance ToParamSchema Day where
   toParamSchema _ = timeParamSchema "date"
 
+-- |
+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
+-- Just "hh:MM:ss"
+instance ToParamSchema TimeOfDay where
+  toParamSchema _ = timeParamSchema "hh:MM:ss"
+
 -- |
 -- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
 -- Just "yyyy-mm-ddThh:MM:ss"

src/Data/Swagger/Internal/Schema.hs

@@ -147,6 +147,10 @@ class ToSchema a where
     Proxy a -> Declare (Definitions Schema) NamedSchema
   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
 
+instance ToSchema TimeOfDay where
+  declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
+    & example ?~ toJSON (TimeOfDay 12 33 15)
+
 -- | Convert a type into a schema and declare all used schema definitions.
 declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
 declareSchema = fmap _namedSchemaSchema . declareNamedSchema

test/Data/Swagger/CommonTestTypes.hs

@@ -648,3 +648,32 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
     }
 }
 |]
+
+
+-- ========================================================================
+-- TimeOfDay
+-- ========================================================================
+data TimeOfDay
+  = Int
+  | Pico
+  deriving (Generic)
+instance ToSchema TimeOfDay
+instance ToParamSchema TimeOfDay
+
+
+timeOfDaySchemaJSON :: Value
+timeOfDaySchemaJSON = [aesonQQ|
+{
+  "example": "12:33:15",
+  "type": "string",
+  "format": "hh:MM:ss"
+}
+|]
+
+timeOfDayParamSchemaJSON :: Value
+timeOfDayParamSchemaJSON = [aesonQQ|
+{
+  "type": "string",
+  "format": "hh:MM:ss"
+}
+|]

test/Data/Swagger/ParamSchemaSpec.hs

@@ -3,9 +3,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Data.Swagger.ParamSchemaSpec where
 
-import Data.Aeson (Value)
+import Data.Aeson
 import Data.Aeson.QQ.Simple
 import Data.Char
 import Data.Proxy
@@ -17,6 +18,9 @@ import Data.Swagger.Internal (SwaggerKind(..))
 import Data.Swagger.CommonTestTypes
 import SpecCommon
 import Test.Hspec
+import Data.Time.LocalTime
+
+import qualified Data.HashMap.Strict as HM
 
 checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
 checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
@@ -30,6 +34,7 @@ spec = do
     context "Unary records" $ do
       context "Email (unary record)"  $ checkToParamSchema (Proxy :: Proxy Email)  emailSchemaJSON
       context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
+    context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
 
 main :: IO ()
 main = hspec spec

test/Data/Swagger/SchemaSpec.hs

@@ -21,6 +21,9 @@ import Data.Swagger.CommonTestTypes
 import SpecCommon
 import Test.Hspec
 
+import qualified Data.HashMap.Strict as HM
+import Data.Time.LocalTime
+
 checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
 checkToSchema proxy js = toSchema proxy <=> js
 
@@ -105,6 +108,7 @@ spec = do
     context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
   describe "Bounded Enum key mapping" $ do
     context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
+    context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay ) timeOfDaySchemaJSON
 
 main :: IO ()
 main = hspec spec