define Key type and implement serialization for Int, String, Date and Array of those

bower.json

@@ -10,7 +10,8 @@
     "purescript-maybe": "3.0.0",
     "purescript-aff": "3.1.0",
     "purescript-test-unit": "11.0.0",
-    "purescript-spec": "1.0.0"
+    "purescript-spec": "1.0.0",
+    "purescript-datetime": "3.2.0"
   },
   "devDependencies": {
     "purescript-psci-support": "3.0.0"

src/Database/IndexedDB/Core.js

@@ -18,6 +18,12 @@ exports.errorHandler = function errorHandler(cb) {
     };
 };
 
+exports.successHandler = function successHandler(cb) {
+    return function _handler(e) {
+        cb(e.target.result);
+    };
+};
+
 exports._showIDBDatabase = function _showIDBDatabase(db) {
     return '(IDBDatabase ' +
         '{ name: ' + db.name +
@@ -41,3 +47,41 @@ exports._showIDBTransaction = function _showIDBTransaction(tx) {
         ', mode: ' + tx.mode +
         ' })';
 };
+
+exports._dateTimeToForeign = function _dateTimeToForeign(y, m, d, h, mi, s, ms) {
+    return new Date(y, m, d, h, mi, s, ms);
+};
+
+exports._readDateTime = function _readDateTime(parse, right, left, date) {
+    if (Object.getPrototypeOf(date) !== Date.prototype) {
+        return left(typeof date);
+    }
+
+    const y = date.getFullYear();
+    const m = date.getMonth() + 1;
+    const d = date.getDate();
+    const h = date.getHours();
+    const mi = date.getMinutes();
+    const s = date.getSeconds();
+    const ms = date.getMilliseconds();
+
+    const mdate = parse(y)(m)(d)(h)(mi)(s)(ms);
+
+    if (mdate == null) {
+        return left(typeof date); // TODO Could return better error
+    }
+
+    return right(mdate);
+};
+
+exports._unsafeReadDateTime = function _unsafeReadDateTime(parse, date) {
+    const y = date.getFullYear();
+    const m = date.getMonth() + 1;
+    const d = date.getDate();
+    const h = date.getHours();
+    const mi = date.getMinutes();
+    const s = date.getSeconds();
+    const ms = date.getMilliseconds();
+
+    return parse(y)(m)(d)(h)(mi)(s)(ms);
+};

src/Database/IndexedDB/Core.purs

@@ -1,10 +1,30 @@
 module Database.IndexedDB.Core where
 
 import Prelude
-import Data.Maybe(Maybe)
-import Control.Monad.Aff(Aff)
-import Control.Monad.Eff(kind Effect, Eff)
-import Control.Monad.Eff.Exception(EXCEPTION)
+
+import Control.Alt                 ((<|>))
+import Control.Monad.Aff           (Aff)
+import Control.Monad.Eff           (kind Effect, Eff)
+import Control.Monad.Eff.Exception (EXCEPTION)
+import Control.Monad.Except        (ExceptT(..), runExceptT)
+import Data.Date                    as Date
+import Data.DateTime                as DateTime
+import Data.DateTime               (DateTime(..), Date(..), Time(..))
+import Data.Either                 (Either(..), isRight)
+import Data.Enum                   (fromEnum, toEnum)
+import Data.Foreign                 as Foreign
+import Data.Foreign                (Foreign, F)
+import Data.Function.Uncurried      as Fn
+import Data.Function.Uncurried     (Fn2, Fn4, Fn7)
+import Data.Identity               (Identity(..))
+import Data.List.NonEmpty          (NonEmptyList(..))
+import Data.List.Types             (List(..))
+import Data.Maybe                  (Maybe)
+import Data.NonEmpty               (NonEmpty(..))
+import Data.Nullable               (Nullable, toNullable)
+import Data.Time                    as Time
+import Data.Traversable            (traverse)
+
 
 foreign import data INDEXED_DB :: Effect
 
@@ -33,3 +53,76 @@ instance showIDBTransaction :: Show IDBTransaction where
 
 
 data IDBTransactionMode = ReadOnly | ReadWrite | VersionChange
+
+
+newtype Key = Key Foreign
+
+
+instance eqKey :: Eq Key where
+  eq a b = (runExceptT >>> runIdentity >>> isRight) $
+      eq <$> ((fromKey a) :: F Int) <*> fromKey b
+    <|>
+      eq <$> ((fromKey a) :: F String) <*> fromKey b
+    <|>
+      eq <$> ((fromKey a) :: F DateTime) <*> fromKey b
+    where
+      runIdentity :: forall a. Identity a -> a
+      runIdentity (Identity a) = a
+
+class Index a where
+  toKey         :: a -> Key
+  fromKey       :: Key -> F a
+  unsafeFromKey :: Key -> a
+
+
+instance indexInt :: Index Int where
+  toKey                 = Foreign.toForeign >>> Key
+  fromKey (Key f)       = Foreign.readInt f
+  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f
+
+
+instance indexString :: Index String where
+  toKey                 = Foreign.toForeign >>> Key
+  fromKey (Key f)       = Foreign.readString f
+  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f
+
+
+instance indexDate :: Index DateTime where
+  toKey (DateTime d t) = Key $ Fn.runFn7 _dateTimeToForeign
+    (fromEnum $ Date.year d)
+    (fromEnum $ Date.month d)
+    (fromEnum $ Date.day d)
+    (fromEnum $ Time.hour t)
+    (fromEnum $ Time.minute t)
+    (fromEnum $ Time.second t)
+    (fromEnum $ Time.millisecond t)
+  fromKey (Key f)       = Fn.runFn4 _readDateTime dateTime dateTimeF dateTimeE f
+  unsafeFromKey (Key f) = Fn.runFn2 _unsafeReadDateTime dateTime f
+
+
+instance indexArray :: Index a => Index (Array a) where
+  toKey                 = Foreign.toForeign >>> Key
+  fromKey (Key f)       = Foreign.readArray f >>= traverse (Key >>> fromKey)
+  unsafeFromKey (Key f) = map unsafeFromKey (Foreign.unsafeFromForeign f)
+
+
+foreign import _dateTimeToForeign  :: Fn7 Int Int Int Int Int Int Int Foreign
+foreign import _readDateTime       :: Fn4 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) (DateTime -> F DateTime) (String -> F DateTime) Foreign (F DateTime)
+foreign import _unsafeReadDateTime :: Fn2 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) Foreign DateTime
+
+
+dateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime
+dateTime y m d h mi s ms =
+  toNullable $ DateTime
+  <$> (Date.canonicalDate <$> toEnum y <*> toEnum m <*> toEnum d)
+  <*> (Time <$> toEnum h <*> toEnum mi <*> toEnum s <*> toEnum ms)
+
+
+dateTimeF :: DateTime -> F DateTime
+dateTimeF =
+  Right >>> Identity >>> ExceptT
+
+
+dateTimeE :: String -> F DateTime
+dateTimeE =
+  Foreign.TypeMismatch "Date" >>> flip NonEmpty Nil >>> NonEmptyList >>> Left >>> Identity >>> ExceptT