Allow format specifier for all date/time types

json-fleece-codegen-util/codegen-prelude.dhall

@@ -1,9 +1,6 @@
 let
   DateTimeFormat = < UTCTime | ZonedTime | LocalTime >
 
-let
-  DateFormat = < ISO8601Date | CustomDate : Text >
-
 let
   DerivableClass = < Show | Eq | Ord | Enum | Bounded >
 
@@ -14,12 +11,12 @@ let
   TypeOptions =
     { Type =
         { dateTimeFormat : DateTimeFormat
-        , dateFormat : DateFormat
+        , formatSpecifier : Optional Text
         , deriveClasses : DeriveClasses
         }
     , default =
         { dateTimeFormat = DateTimeFormat.UTCTime
-        , dateFormat = DateFormat.ISO8601Date
+        , formatSpecifier = None Text
         , deriveClasses = DeriveClasses.Default
         }
     }
@@ -50,7 +47,6 @@ in
   , utcTime = DateTimeFormat.UTCTime
   , zonedTime = DateTimeFormat.ZonedTime
   , localTime = DateTimeFormat.LocalTime
-  , customDate = DateFormat.CustomDate
   , show = DerivableClass.Show
   , eq = DerivableClass.Eq
   , ord = DerivableClass.Ord

json-fleece-codegen-util/src/Fleece/CodeGenUtil.hs

@@ -4,7 +4,6 @@
 module Fleece.CodeGenUtil
   ( generateFleeceCode
   , CodeGenOptions (..)
-  , DateFormat (..)
   , DateTimeFormat (..)
   , TypeOptions (..)
   , DerivableClass (..)
@@ -53,7 +52,6 @@ module Fleece.CodeGenUtil
   , floatFormat
   , doubleFormat
   , dayFormat
-  , dayCustomFormat
   , utcTimeFormat
   , zonedTimeFormat
   , localTimeFormat
@@ -98,7 +96,7 @@ data CodeGenOptions = CodeGenOptions
 
 data TypeOptions = TypeOptions
   { dateTimeFormat :: DateTimeFormat
-  , dateFormat :: DateFormat
+  , formatSpecifier :: Maybe T.Text
   , deriveClasses :: Maybe [DerivableClass]
   }
 
@@ -136,10 +134,6 @@ lookupTypeOptions typeName = do
     Nothing -> asks defaultTypeOptions
     Just typeOptions -> pure typeOptions
 
-data DateFormat
-  = ISO8601DateFormat
-  | CustomDateFormat T.Text
-
 data DateTimeFormat
   = UTCTimeFormat
   | ZonedTimeFormat
@@ -332,40 +326,51 @@ schemaInfoOrRefToSchemaTypeInfo typeMap refOrInfo =
 
 dayFormat :: TypeOptions -> CodeGenDataFormat
 dayFormat typeOptions =
-  codeGenNewTypeSchemaTypeInfo typeOptions $
-    primitiveSchemaTypeInfo
-      (HC.toTypeName "Data.Time" (Just "Time") "Day")
-      (fleeceCoreVar "day")
-
-dayCustomFormat :: T.Text -> TypeOptions -> CodeGenDataFormat
-dayCustomFormat formatString typeOptions =
   codeGenNewTypeSchemaTypeInfo typeOptions
     $ primitiveSchemaTypeInfo
       (HC.toTypeName "Data.Time" (Just "Time") "Day")
-    $ HC.fromCode "("
-      <> fleeceCoreFunApp "dayWithFormat" formatString
-      <> HC.fromCode ")"
+    $ case formatSpecifier typeOptions of
+      Just formatString ->
+        HC.fromCode "("
+          <> fleeceCoreFunApp "dayWithFormat" formatString
+          <> HC.fromCode ")"
+      Nothing -> fleeceCoreVar "day"
 
 utcTimeFormat :: TypeOptions -> CodeGenDataFormat
 utcTimeFormat typeOptions =
-  codeGenNewTypeSchemaTypeInfo typeOptions $
-    primitiveSchemaTypeInfo
+  codeGenNewTypeSchemaTypeInfo typeOptions
+    $ primitiveSchemaTypeInfo
       (HC.toTypeName "Data.Time" (Just "Time") "UTCTime")
-      (fleeceCoreVar "utcTime")
+    $ case formatSpecifier typeOptions of
+      Just formatString ->
+        HC.fromCode "("
+          <> fleeceCoreFunApp "utcTimeWithFormat" formatString
+          <> HC.fromCode ")"
+      Nothing -> fleeceCoreVar "utcTime"
 
 zonedTimeFormat :: TypeOptions -> CodeGenDataFormat
 zonedTimeFormat typeOptions =
-  codeGenNewTypeSchemaTypeInfo typeOptions $
-    primitiveSchemaTypeInfo
+  codeGenNewTypeSchemaTypeInfo typeOptions
+    $ primitiveSchemaTypeInfo
       (HC.toTypeName "Data.Time" (Just "Time") "ZonedTime")
-      (fleeceCoreVar "zonedTime")
+    $ case formatSpecifier typeOptions of
+      Just formatString ->
+        HC.fromCode "("
+          <> fleeceCoreFunApp "zonedTimeWithFormat" formatString
+          <> HC.fromCode ")"
+      Nothing -> fleeceCoreVar "zonedTime"
 
 localTimeFormat :: TypeOptions -> CodeGenDataFormat
 localTimeFormat typeOptions =
-  codeGenNewTypeSchemaTypeInfo typeOptions $
-    primitiveSchemaTypeInfo
+  codeGenNewTypeSchemaTypeInfo typeOptions
+    $ primitiveSchemaTypeInfo
       (HC.toTypeName "Data.Time" (Just "Time") "LocalTime")
-      (fleeceCoreVar "localTime")
+    $ case formatSpecifier typeOptions of
+      Just formatString ->
+        HC.fromCode "("
+          <> fleeceCoreFunApp "localTimeWithFormat" formatString
+          <> HC.fromCode ")"
+      Nothing -> fleeceCoreVar "localTime"
 
 textFormat :: TypeOptions -> CodeGenDataFormat
 textFormat typeOptions =

json-fleece-codegen-util/src/Fleece/CodeGenUtil/Config.hs

@@ -45,15 +45,11 @@ typeOptionsDecoder =
   Dhall.record $
     CGU.TypeOptions
       <$> Dhall.field "dateTimeFormat" dateTimeFormatDecoder
-      <*> Dhall.field "dateFormat" dateFormatDecoder
+      <*> Dhall.field "formatSpecifier" formatSpecifierDecoder
       <*> Dhall.field "deriveClasses" deriveClassesDecoder
 
-dateFormatDecoder :: Dhall.Decoder CGU.DateFormat
-dateFormatDecoder =
-  Dhall.union
-    ( (fmap (\() -> CGU.ISO8601DateFormat) (Dhall.constructor "ISO8601Date" Dhall.unit))
-        <> (fmap CGU.CustomDateFormat (Dhall.constructor "CustomDate" Dhall.strictText))
-    )
+formatSpecifierDecoder :: Dhall.Decoder (Maybe T.Text)
+formatSpecifierDecoder = Dhall.maybe Dhall.strictText
 
 dateTimeFormatDecoder :: Dhall.Decoder CGU.DateTimeFormat
 dateTimeFormatDecoder =

json-fleece-core/src/Fleece/Core.hs

@@ -68,8 +68,11 @@ module Fleece.Core
   , set
   , string
   , utcTime
+  , utcTimeWithFormat
   , localTime
+  , localTimeWithFormat
   , zonedTime
+  , zonedTimeWithFormat
   , day
   , dayWithFormat
   , boundedIntegralNumber

json-fleece-core/src/Fleece/Core/Schemas.hs

@@ -30,10 +30,14 @@ module Fleece.Core.Schemas
   , realFloatNamed
   , string
   , utcTime
+  , utcTimeWithFormat
   , localTime
+  , localTimeWithFormat
   , zonedTime
+  , zonedTimeWithFormat
   , day
   , dayWithFormat
+  , timeWithFormat
   , boundedIntegralNumber
   , boundedIntegralNumberNamed
   , unboundedIntegralNumber
@@ -562,34 +566,46 @@ utcTime :: Fleece schema => schema Time.UTCTime
 utcTime =
   iso8601Formatted "UTCTime" ISO8601.iso8601Format AttoTime.utcTime
 
+utcTimeWithFormat :: Fleece schema => String -> schema Time.UTCTime
+utcTimeWithFormat = timeWithFormat "UTCTime"
+
 localTime :: Fleece schema => schema Time.LocalTime
 localTime =
   iso8601Formatted "LocalTime" ISO8601.iso8601Format AttoTime.localTime
 
+localTimeWithFormat :: Fleece schema => String -> schema Time.LocalTime
+localTimeWithFormat = timeWithFormat "LocalTime"
+
 zonedTime :: Fleece schema => schema Time.ZonedTime
 zonedTime =
   iso8601Formatted "ZonedTime" ISO8601.iso8601Format AttoTime.zonedTime
 
+zonedTimeWithFormat :: Fleece schema => String -> schema Time.ZonedTime
+zonedTimeWithFormat = timeWithFormat "ZonedTime"
+
+day :: Fleece schema => schema Time.Day
+day =
+  iso8601Formatted "Day" ISO8601.iso8601Format AttoTime.day
+
 dayWithFormat :: Fleece schema => String -> schema Time.Day
-dayWithFormat formatString =
+dayWithFormat = timeWithFormat "Day"
+
+timeWithFormat :: (Time.FormatTime t, Time.ParseTime t) => Fleece schema => String -> String -> schema t
+timeWithFormat typeName formatString =
   let
     decode raw =
       case Time.parseTimeM False Time.defaultTimeLocale formatString raw of
         Just success -> Right success
         Nothing ->
           Left $
-            "Invalid date in custom format, format is: " <> formatString
+            "Invalid " <> typeName <> ", custom format is: " <> formatString
   in
     validateNamed
-      (unqualifiedName $ "Day in " <> formatString <> " format")
+      (unqualifiedName $ typeName <> " in " <> formatString <> " format")
       (Time.formatTime Time.defaultTimeLocale formatString)
       decode
       string
 
-day :: Fleece schema => schema Time.Day
-day =
-  iso8601Formatted "Day" ISO8601.iso8601Format AttoTime.day
-
 bareOrJSONString :: Fleece schema => schema a -> schema a
 bareOrJSONString baseSchema =
   let

json-fleece-openapi3/examples/test-cases/TestCases/Types/DateTimeFormats.hs

@@ -8,6 +8,9 @@ module TestCases.Types.DateTimeFormats
 import Fleece.Core ((#+))
 import qualified Fleece.Core as FC
 import Prelude (($), Maybe, Show)
+import qualified TestCases.Types.DateTimeFormats.CustomLocalTimeField as CustomLocalTimeField
+import qualified TestCases.Types.DateTimeFormats.CustomUtcTimeField as CustomUtcTimeField
+import qualified TestCases.Types.DateTimeFormats.CustomZonedTimeField as CustomZonedTimeField
 import qualified TestCases.Types.DateTimeFormats.DefaultTimeField as DefaultTimeField
 import qualified TestCases.Types.DateTimeFormats.LocalTimeField as LocalTimeField
 import qualified TestCases.Types.DateTimeFormats.UtcTimeField as UtcTimeField
@@ -17,7 +20,10 @@ data DateTimeFormats = DateTimeFormats
   { zonedTimeField :: Maybe ZonedTimeField.ZonedTimeField
   , defaultTimeField :: Maybe DefaultTimeField.DefaultTimeField
   , localTimeField :: Maybe LocalTimeField.LocalTimeField
+  , customLocalTimeField :: Maybe CustomLocalTimeField.CustomLocalTimeField
   , utcTimeField :: Maybe UtcTimeField.UtcTimeField
+  , customZonedTimeField :: Maybe CustomZonedTimeField.CustomZonedTimeField
+  , customUtcTimeField :: Maybe CustomUtcTimeField.CustomUtcTimeField
   }
   deriving (Show)
 
@@ -28,4 +34,7 @@ dateTimeFormatsSchema =
       #+ FC.optional "zonedTimeField" zonedTimeField ZonedTimeField.zonedTimeFieldSchema
       #+ FC.optional "defaultTimeField" defaultTimeField DefaultTimeField.defaultTimeFieldSchema
       #+ FC.optional "localTimeField" localTimeField LocalTimeField.localTimeFieldSchema
-      #+ FC.optional "utcTimeField" utcTimeField UtcTimeField.utcTimeFieldSchema
+      #+ FC.optional "customLocalTimeField" customLocalTimeField CustomLocalTimeField.customLocalTimeFieldSchema
+      #+ FC.optional "utcTimeField" utcTimeField UtcTimeField.utcTimeFieldSchema
+      #+ FC.optional "customZonedTimeField" customZonedTimeField CustomZonedTimeField.customZonedTimeFieldSchema
+      #+ FC.optional "customUtcTimeField" customUtcTimeField CustomUtcTimeField.customUtcTimeFieldSchema

json-fleece-openapi3/examples/test-cases/TestCases/Types/DateTimeFormats/CustomLocalTimeField.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.DateTimeFormats.CustomLocalTimeField
+  ( CustomLocalTimeField(..)
+  , customLocalTimeFieldSchema
+  ) where
+
+import qualified Data.Time as Time
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype CustomLocalTimeField = CustomLocalTimeField Time.LocalTime
+  deriving (Show, Eq)
+
+customLocalTimeFieldSchema :: FC.Fleece schema => schema CustomLocalTimeField
+customLocalTimeFieldSchema =
+  FC.coerceSchema (FC.localTimeWithFormat "local")

json-fleece-openapi3/examples/test-cases/TestCases/Types/DateTimeFormats/CustomUtcTimeField.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.DateTimeFormats.CustomUtcTimeField
+  ( CustomUtcTimeField(..)
+  , customUtcTimeFieldSchema
+  ) where
+
+import qualified Data.Time as Time
+import qualified Fleece.Core as FC
+import Prelude (Eq, Show)
+
+newtype CustomUtcTimeField = CustomUtcTimeField Time.UTCTime
+  deriving (Show, Eq)
+
+customUtcTimeFieldSchema :: FC.Fleece schema => schema CustomUtcTimeField
+customUtcTimeFieldSchema =
+  FC.coerceSchema (FC.utcTimeWithFormat "utc")

json-fleece-openapi3/examples/test-cases/TestCases/Types/DateTimeFormats/CustomZonedTimeField.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module TestCases.Types.DateTimeFormats.CustomZonedTimeField
+  ( CustomZonedTimeField(..)
+  , customZonedTimeFieldSchema
+  ) where
+
+import qualified Data.Time as Time
+import qualified Fleece.Core as FC
+import Prelude (Show)
+
+newtype CustomZonedTimeField = CustomZonedTimeField Time.ZonedTime
+  deriving (Show)
+
+customZonedTimeFieldSchema :: FC.Fleece schema => schema CustomZonedTimeField
+customZonedTimeFieldSchema =
+  FC.coerceSchema (FC.zonedTimeWithFormat "zoned")

json-fleece-openapi3/examples/test-cases/codegen.dhall

@@ -13,7 +13,7 @@ in
           [ { type = "TestCases.Types.CustomDateFormat.CustomDateFormat"
             , options =
                 CodeGen.TypeOptions::
-                  { dateFormat = CodeGen.customDate "%m/%d/%y"
+                  { formatSpecifier = Some "%m/%d/%y"
                   }
             }
           , { type = "TestCases.Types.DateTimeFormats.DateTimeFormats"
@@ -41,6 +41,28 @@ in
                   { dateTimeFormat = CodeGen.localTime
                   }
             }
+          , { type = "TestCases.Types.DateTimeFormats.CustomUtcTimeField.CustomUtcTimeField"
+            , options =
+                CodeGen.TypeOptions::
+                  { dateTimeFormat = CodeGen.utcTime
+                  , formatSpecifier = Some "utc"
+                  }
+            }
+          , { type = "TestCases.Types.DateTimeFormats.CustomZonedTimeField.CustomZonedTimeField"
+            , options =
+                CodeGen.TypeOptions::
+                  { dateTimeFormat = CodeGen.zonedTime
+                  , formatSpecifier = Some "zoned"
+                  , deriveClasses = CodeGen.derive [ CodeGen.show ]
+                  }
+            }
+          , { type = "TestCases.Types.DateTimeFormats.CustomLocalTimeField.CustomLocalTimeField"
+            , options =
+                CodeGen.TypeOptions::
+                  { dateTimeFormat = CodeGen.localTime
+                  , formatSpecifier = Some "local"
+                  }
+            }
           , { type = "TestCases.Types.UtcTimeType.UtcTimeType"
             , options =
                 CodeGen.TypeOptions::

json-fleece-openapi3/examples/test-cases/test-cases.cabal

@@ -80,6 +80,9 @@ library
       TestCases.Types.AStringType
       TestCases.Types.CustomDateFormat
       TestCases.Types.DateTimeFormats
+      TestCases.Types.DateTimeFormats.CustomLocalTimeField
+      TestCases.Types.DateTimeFormats.CustomUtcTimeField
+      TestCases.Types.DateTimeFormats.CustomZonedTimeField
       TestCases.Types.DateTimeFormats.DefaultTimeField
       TestCases.Types.DateTimeFormats.LocalTimeField
       TestCases.Types.DateTimeFormats.UtcTimeField

json-fleece-openapi3/examples/test-cases/test-cases.yaml

@@ -668,6 +668,15 @@ components:
         localTimeField:
           type: string
           format: date-time
+        customUtcTimeField:
+          type: string
+          format: date-time
+        customZonedTimeField:
+          type: string
+          format: date-time
+        customLocalTimeField:
+          type: string
+          format: date-time
 
     DefaultTimeType:
       type: string