Use proper types for date/time values (#15)

* Use proper types for date/time values

* Fix JSON codec

* Fix syntax parsing

Author: garyb

bower.json

@@ -15,14 +15,15 @@
     "package.json"
   ],
   "dependencies": {
+    "purescript-argonaut": "^2.0.0",
     "purescript-bifunctors": "^2.0.0",
+    "purescript-datetime": "^2.1.1",
     "purescript-maps": "^2.0.0",
     "purescript-matryoshka": "^0.2.0",
     "purescript-newtype": "^1.2.0",
     "purescript-parsing": "^3.0.0",
     "purescript-precise": "^1.0.0",
     "purescript-profunctor-lenses": "^2.4.0",
-    "purescript-strongcheck": "^2.0.0",
-    "purescript-argonaut": "^2.0.0"
+    "purescript-strongcheck": "^2.0.0"
   }
 }

src/Data/Json/Extended.purs

@@ -49,6 +49,7 @@ import Control.Lazy as Lazy
 import Data.Argonaut as JS
 import Data.Array as A
 import Data.Bitraversable (bitraverse)
+import Data.DateTime as DT
 import Data.Either as E
 import Data.Functor.Mu as Mu
 import Data.HugeNum as HN
@@ -61,7 +62,7 @@ import Data.StrMap as SM
 import Data.Traversable (for)
 import Data.Tuple as T
 
-import Matryoshka (embed, project, cata, anaM)
+import Matryoshka (class Corecursive, class Recursive, anaM, cata, embed, project)
 
 import Test.StrongCheck.Arbitrary as SC
 import Test.StrongCheck.Gen as Gen
@@ -71,11 +72,10 @@ import Data.Json.Extended.Signature hiding (getType) as Exports
 
 type EJson = Mu.Mu Sig.EJsonF
 
-
-decodeEJson ∷ JS.Json → E.Either String EJson
+decodeEJson :: forall t. Corecursive t Sig.EJsonF ⇒ JS.Json → E.Either String t
 decodeEJson = anaM Sig.decodeJsonEJsonF
 
-encodeEJson ∷ EJson → JS.Json
+encodeEJson :: forall t. Recursive t Sig.EJsonF ⇒ t -> JS.Json
 encodeEJson = cata Sig.encodeJsonEJsonF
 
 arbitraryEJsonOfSize
@@ -105,120 +105,118 @@ renderEJson ∷ EJson → String
 renderEJson =
   cata Sig.renderEJsonF
 
-
 -- | A closed parser of SQL^2 constant expressions
-parseEJson ∷ ∀ m. (Monad m) ⇒ P.ParserT String m EJson
+parseEJson ∷ ∀ m. Monad m ⇒ P.ParserT String m EJson
 parseEJson =
   Lazy.fix \f →
     embed <$>
       Sig.parseEJsonF f
 
-
-null ∷ EJson
+null ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ t
 null = embed Sig.Null
 
-boolean ∷ Boolean → EJson
+boolean ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Boolean → t
 boolean = embed <<< Sig.Boolean
 
-integer ∷ Int → EJson
+integer ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Int → t
 integer = embed <<< Sig.Integer
 
-decimal ∷ HN.HugeNum → EJson
+decimal ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ HN.HugeNum → t
 decimal = embed <<< Sig.Decimal
 
-string ∷ String → EJson
+string ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ String → t
 string = embed <<< Sig.String
 
-timestamp ∷ String → EJson
+timestamp ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ DT.DateTime → t
 timestamp = embed <<< Sig.Timestamp
 
-date ∷ String → EJson
+date ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ DT.Date → t
 date = embed <<< Sig.Date
 
-time ∷ String → EJson
+time ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ DT.Time → t
 time = embed <<< Sig.Time
 
-interval ∷ String → EJson
+interval ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ String → t
 interval = embed <<< Sig.Interval
 
-objectId ∷ String → EJson
+objectId ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ String → t
 objectId = embed <<< Sig.ObjectId
 
-array ∷ Array EJson → EJson
+array ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Array t → t
 array = embed <<< Sig.Array
 
-map ∷ Map.Map EJson EJson → EJson
+map ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Map.Map t t → t
 map = embed <<< Sig.Map <<< A.fromFoldable <<< Map.toList
 
-map' ∷ SM.StrMap EJson → EJson
+map' ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ SM.StrMap t → t
 map' = embed <<< Sig.Map <<< F.map go <<< A.fromFoldable <<< SM.toList
   where
     go (T.Tuple a b) = T.Tuple (string a) b
 
-getType ∷ EJson → EJsonType
+getType ∷ ∀ t. Recursive t Sig.EJsonF ⇒ t → EJsonType
 getType = Sig.getType <<< project
 
-_Null ∷ Prism' EJson Unit
+_Null ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t Unit
 _Null = prism' (const null) $ project >>> case _ of
   Sig.Null → M.Just unit
   _ → M.Nothing
 
-_String ∷ Prism' EJson String
+_String ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t String
 _String = prism' string $ project >>> case _ of
   Sig.String s → M.Just s
   _ → M.Nothing
 
-_Boolean ∷ Prism' EJson Boolean
+_Boolean ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t Boolean
 _Boolean = prism' boolean $ project >>> case _ of
   Sig.Boolean b → M.Just b
   _ → M.Nothing
 
-_Integer ∷ Prism' EJson Int
+_Integer ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t Int
 _Integer = prism' integer $ project >>> case _ of
   Sig.Integer i → M.Just i
   _ → M.Nothing
 
-_Decimal ∷ Prism' EJson HN.HugeNum
+_Decimal ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t HN.HugeNum
 _Decimal = prism' decimal $ project >>> case _ of
   Sig.Decimal d → M.Just d
   _ → M.Nothing
 
-_Timestamp ∷ Prism' EJson String
+_Timestamp ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t DT.DateTime
 _Timestamp = prism' timestamp $ project >>> case _ of
   Sig.Timestamp t → M.Just t
   _ → M.Nothing
 
-_Date ∷ Prism' EJson String
+_Date ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t DT.Date
 _Date = prism' date $ project >>> case _ of
   Sig.Date d → M.Just d
   _ → M.Nothing
 
-_Time ∷ Prism' EJson String
+_Time ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t DT.Time
 _Time = prism' time $ project >>> case _ of
   Sig.Time t → M.Just t
   _ → M.Nothing
 
-_Interval ∷ Prism' EJson String
+_Interval ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t String
 _Interval = prism' interval $ project >>> case _ of
   Sig.Interval i → M.Just i
   _ → M.Nothing
 
-_ObjectId ∷ Prism' EJson String
+_ObjectId ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t String
 _ObjectId = prism' objectId $ project >>> case _ of
   Sig.ObjectId id → M.Just id
   _ → M.Nothing
 
-_Array ∷ Prism' EJson (Array EJson)
+_Array ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t (Array t)
 _Array = prism' array $ project >>> case _ of
   Sig.Array xs → M.Just xs
   _ → M.Nothing
 
-_Map ∷ Prism' EJson (Map.Map EJson EJson)
+_Map ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF, Ord t) ⇒ Prism' t (Map.Map t t)
 _Map = prism' map $ project >>> case _ of
   Sig.Map kvs → M.Just $ Map.fromFoldable kvs
   _ → M.Nothing
 
-_Map' ∷ Prism' EJson (SM.StrMap EJson)
+_Map' ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t (SM.StrMap t)
 _Map' = prism' map' $ project >>> case _ of
   Sig.Map kvs → SM.fromFoldable <$> for kvs (bitraverse (preview _String) pure)
   _ → M.Nothing

src/Data/Json/Extended/Signature/Core.purs

@@ -6,15 +6,16 @@ module Data.Json.Extended.Signature.Core
 import Prelude
 
 import Data.Bifunctor as BF
+import Data.DateTime as DT
 import Data.Eq (class Eq1, eq1)
 import Data.Foldable as F
-import Data.Traversable as T
 import Data.HugeNum as HN
 import Data.Int as Int
 import Data.Json.Extended.Type as JT
 import Data.List as L
 import Data.Monoid (mempty)
 import Data.Ord (class Ord1)
+import Data.Traversable as T
 import Data.Tuple (Tuple(..))
 import Data.TacitString (TacitString)
 
@@ -25,9 +26,9 @@ data EJsonF a
   | Boolean Boolean
   | Integer Int
   | Decimal HN.HugeNum
-  | Timestamp String
-  | Date String
-  | Time String
+  | Timestamp DT.DateTime
+  | Date DT.Date
+  | Time DT.Time
   | Interval String
   | ObjectId String
   | Array (Array a)

src/Data/Json/Extended/Signature/Gen.purs

@@ -7,9 +7,12 @@ module Data.Json.Extended.Signature.Gen
 import Prelude
 
 import Data.Array as A
+import Data.DateTime as DT
+import Data.Enum (toEnum)
+import Data.HugeNum as HN
 import Data.Json.Extended.Signature.Core (EJsonF(..))
+import Data.Maybe (fromMaybe)
 import Data.Tuple as T
-import Data.HugeNum as HN
 
 import Test.StrongCheck.Arbitrary as SC
 import Test.StrongCheck.Gen as Gen
@@ -21,9 +24,9 @@ arbitraryBaseEJsonF =
     , Integer <$> SC.arbitrary
     , Decimal <$> arbitraryDecimal
     , String <$> SC.arbitrary
-    , Timestamp <$> SC.arbitrary
-    , Date <$> SC.arbitrary
-    , Time <$> SC.arbitrary
+    , Timestamp <$> arbitraryDateTime
+    , Date <$> arbitraryDate
+    , Time <$> arbitraryTime
     , Interval <$> SC.arbitrary
     , ObjectId <$> SC.arbitrary
     , pure Null
@@ -73,3 +76,27 @@ arbitraryDecimal ∷ Gen.Gen HN.HugeNum
 arbitraryDecimal =
   HN.fromNumber
     <$> SC.arbitrary
+
+arbitraryDateTime ∷ Gen.Gen DT.DateTime
+arbitraryDateTime = DT.DateTime <$> arbitraryDate <*> arbitraryTime
+
+arbitraryDate ∷ Gen.Gen DT.Date
+arbitraryDate = do
+  year ← Gen.chooseInt 1950 2050
+  month ← Gen.chooseInt 1 12
+  day ← Gen.chooseInt 1 31
+  pure $ DT.canonicalDate
+    (fromMaybe bottom (toEnum year))
+    (fromMaybe bottom (toEnum month))
+    (fromMaybe bottom (toEnum day))
+
+arbitraryTime ∷ Gen.Gen DT.Time
+arbitraryTime = do
+  hour ← Gen.chooseInt 0 23
+  minute ← Gen.chooseInt 0 59
+  second ← Gen.chooseInt 0 59
+  pure $ DT.Time
+    (fromMaybe bottom (toEnum hour))
+    (fromMaybe bottom (toEnum minute))
+    (fromMaybe bottom (toEnum second))
+    bottom

src/Data/Json/Extended/Signature/Json.purs

@@ -4,19 +4,23 @@ import Prelude
 
 import Control.Alt ((<|>))
 
-import Data.Bifunctor (lmap)
 import Data.Argonaut.Core as JS
 import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
 import Data.Argonaut.Encode (encodeJson)
 import Data.Array as A
+import Data.Bifunctor (lmap)
+import Data.DateTime as DT
 import Data.Either as E
 import Data.HugeNum as HN
 import Data.Int as Int
 import Data.Json.Extended.Signature.Core (EJsonF(..))
+import Data.Json.Extended.Signature.Parse (parseDate, parseTime, parseTimestamp)
+import Data.Json.Extended.Signature.Render (renderDate, renderTime, renderTimestamp)
 import Data.Maybe as M
 import Data.StrMap as SM
 import Data.Traversable as TR
 import Data.Tuple as T
+import Text.Parsing.Parser as P
 
 import Matryoshka (Algebra, CoalgebraM)
 
@@ -27,9 +31,9 @@ encodeJsonEJsonF = case _ of
   Integer i → encodeJson i
   Decimal a → encodeJson $ HN.toNumber a
   String str → encodeJson str
-  Timestamp str → JS.jsonSingletonObject "$timestamp" $ encodeJson str
-  Time str → JS.jsonSingletonObject "$time" $ encodeJson str
-  Date str → JS.jsonSingletonObject "$date" $ encodeJson str
+  Timestamp dt → JS.jsonSingletonObject "$timestamp" $ encodeJson $ renderTimestamp dt
+  Time t → JS.jsonSingletonObject "$time" $ encodeJson $ renderTime t
+  Date d → JS.jsonSingletonObject "$date" $ encodeJson $ renderDate d
   Interval str → JS.jsonSingletonObject "$interval" $ encodeJson str
   ObjectId str → JS.jsonSingletonObject "$oid" $ encodeJson str
   Array xs → encodeJson xs
@@ -72,11 +76,11 @@ decodeJsonEJsonF =
     → E.Either String (EJsonF JS.Json)
   decodeObject obj =
     unwrapBranch "$obj" strMapObject obj
-    <|> unwrapLeaf "$timestamp" Timestamp obj
-    <|> unwrapLeaf "$date" Date obj
-    <|> unwrapLeaf "$time" Time obj
-    <|> unwrapLeaf "$interval" Interval obj
-    <|> unwrapLeaf "$oid" ObjectId obj
+    <|> unwrapLeaf "$timestamp" decodeTimestamp Timestamp obj
+    <|> unwrapLeaf "$date" decodeDate Date obj
+    <|> unwrapLeaf "$time" decodeTime Time obj
+    <|> unwrapLeaf "$interval" decodeJson Interval obj
+    <|> unwrapLeaf "$oid" decodeJson ObjectId obj
     <|> unwrapNull obj
     <|> (pure $ strMapObject obj)
 
@@ -112,14 +116,14 @@ decodeJsonEJsonF =
 
   unwrapLeaf
     ∷ ∀ b
-    . (DecodeJson b)
-    ⇒ String
+    . String
+    → (JS.Json → E.Either String b)
     → (b → EJsonF JS.Json)
     → JS.JObject
     → E.Either String (EJsonF JS.Json)
-  unwrapLeaf key codec =
+  unwrapLeaf key decode codec =
     getOnlyKey key
-      >=> decodeJson
+      >=> decode
       >>> map codec
 
   getOnlyKey
@@ -131,3 +135,15 @@ decodeJsonEJsonF =
       obj .? key
     keys →
       E.Left $ "Expected '" <> key <> "' to be the only key, but found: " <> show keys
+
+decodeTimestamp ∷ JS.Json → E.Either String DT.DateTime
+decodeTimestamp = decodeJson >=> \val →
+  lmap show $ P.runParser val parseTimestamp
+
+decodeDate ∷ JS.Json → E.Either String DT.Date
+decodeDate = decodeJson >=> \val →
+  lmap show $ P.runParser val parseDate
+
+decodeTime ∷ JS.Json → E.Either String DT.Time
+decodeTime = decodeJson >=> \val →
+  lmap show $ P.runParser val parseTime