add test cases for IDBKeyRange

add test cases for IDBKeyRange

module Test.Main where

import Prelude

import Control.Monad.Aff                 (Aff, launchAff, forkAff, delay)
import Control.Monad.Aff.AVar            (AVAR, makeVar', modifyVar, peekVar, killVar)
import Control.Monad.Eff                 (Eff)
import Control.Monad.Eff.Class           (liftEff)
import Control.Monad.Eff.Exception       (EXCEPTION)
import Data.Date                          as Date
import Data.DateTime                      as DateTime
import Data.DateTime                     (DateTime(..), Date(..), Time(..))
import Data.Enum                         (toEnum)
import Data.Maybe                        (Maybe(..))
import Data.Time.Duration                (Milliseconds(..))
import Test.Spec                         (describe, it)
import Test.Spec.Assertions              (shouldEqual, fail)
import Test.Spec.Mocha                   (MOCHA, runMocha)

import Database.IndexedDB.Core
import Database.IndexedDB.IDBKey
import Database.IndexedDB.IDBDatabase     as IDBDatabase
import Database.IndexedDB.IDBFactory      as IDBFactory
import Database.IndexedDB.IDBObjectStore  as IDBObjectStore
import Database.IndexedDB.IDBKeyRange     as IDBKeyRange

tearDown :: forall eff. String -> Int -> Database -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Unit
tearDown name version db = do
  liftEff $ IDBDatabase.close db
  version' <- IDBFactory.deleteDatabase name
  version' `shouldEqual` version

-- main :: forall eff. Eff (mocha :: MOCHA, idb :: INDEXED_DB, exception :: EXCEPTION, avar :: AVAR | eff) Unit
main = runMocha do
  describe "IDBFactory" do
    it "open default" do
      let name    = "db-default"
          version = 1
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version" do
      let name    = "db-specific"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version -> close -> open latest" do
      let name    = "db-latest"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      liftEff $ IDBDatabase.close db
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      tearDown name version db

    it "open + onUpgradeNeed" do
      let name    = "db-upgrade-needed"
          version = 1
          callback var db = do
            _ <- launchAff $ modifyVar (const $ IDBDatabase.name db) var
            pure unit
      var <- makeVar' "-"
      db  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db

    it "open + onBlocked" do
      let name    = "db-blocked"
          version = 14
          callback var = do
            _ <- launchAff $ modifyVar (const $ "db-blocked") var
            pure unit

      var   <- makeVar' "-"
      db01  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      _ <- forkAff do
        delay (Milliseconds 100.0)
        liftEff $ IDBDatabase.close db01

      db02  <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Just (callback var)
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db02

  describe "IDBKeyRange" do
    it "only(int)" do
      let key   = 14
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(string)" do
      let key   = "patate"
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(float)" do
      let key   = 14.42
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(date)" do
      let mkey = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let range = IDBKeyRange.new $ IDBKeyRange.Only key
          IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([int])" do
      let key   = [14, 42]
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([string])" do
      let key   = ["patate", "autruche"]
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

  describe "IDBDatabase" do
    it "createObjectStore (keyPath: [], autoIncrement: true)" do
      let dbName          = "db-create-store-01"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = []
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: true)" do
      let dbName          = "db-create-store-02"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"a\", \"b\"], autoIncrement: false)" do
      let dbName          = "db-create-store-03"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["a", "b"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: false)" do
      let dbName          = "db-create-store-04"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "deleteObjectStore" do
      let dbName           = "db-delete-store"
          dbVersion        = 2
          storeName        = "store"
          keyPath          = []
          autoIncrement    = true
          callback db      = do
            _ <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            pure unit
          callback2 var db = do
            _ <- IDBDatabase.deleteObjectStore db storeName
            _ <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      liftEff $ IDBDatabase.close db
      db  <- IDBFactory.open dbName (Just dbVersion)
        { onUpgradeNeeded : Just (callback2 var)
        , onBlocked       : Nothing
      }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

  describe "IDBObjectStore" do
    it "add(\"patate\", Nothing )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 1
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" Nothing)
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just 14 )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 14
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just \"key\" )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = "key"
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just <date> )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          mkey          = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let callback db   = do
                store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
                key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
                  <$> IDBObjectStore.add store "patate" (Just $ toKey key))
                pure unit

          db <- IDBFactory.open dbName Nothing
            { onUpgradeNeeded : Just callback
            , onBlocked       : Nothing
            }
          tearDown dbName dbVersion db

    it "add(\"patate\", Just [14, 42] )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = [14, 42]
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "clear()" do
      let dbName        = "db-clear"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ do
              _ <- IDBObjectStore.add store "patate" (Just $ toKey 14)
              _ <- IDBObjectStore.clear store
              v <- IDBObjectStore.get store (IDBKeyRange.new $ IDBKeyRange.Only 14)
              v `shouldEqual` (Nothing :: Maybe Int)

            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

module Test.Main where

import Prelude

import Control.Monad.Aff                 (Aff, launchAff, forkAff, delay)
import Control.Monad.Aff.AVar            (AVAR, makeVar', modifyVar, peekVar, killVar)
import Control.Monad.Eff                 (Eff)
import Control.Monad.Eff.Class           (liftEff)
import Control.Monad.Eff.Exception       (EXCEPTION)
import Data.Date                          as Date
import Data.DateTime                      as DateTime
import Data.DateTime                     (DateTime(..), Date(..), Time(..))
import Data.Enum                         (toEnum)
import Data.Maybe                        (Maybe(..))
import Data.Time.Duration                (Milliseconds(..))
import Test.Spec                         (describe, it)
import Test.Spec.Assertions              (shouldEqual, fail)
import Test.Spec.Mocha                   (MOCHA, runMocha)

import Database.IndexedDB.Core
import Database.IndexedDB.IDBKey
import Database.IndexedDB.IDBDatabase     as IDBDatabase
import Database.IndexedDB.IDBFactory      as IDBFactory
import Database.IndexedDB.IDBObjectStore  as IDBObjectStore

tearDown :: forall eff. String -> Int -> Database -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Unit
tearDown name version db = do
  liftEff $ IDBDatabase.close db
  version' <- IDBFactory.deleteDatabase name
  version' `shouldEqual` version

-- main :: forall eff. Eff (mocha :: MOCHA, idb :: INDEXED_DB, exception :: EXCEPTION, avar :: AVAR | eff) Unit
main = runMocha do
  describe "IDBFactory" do
    it "open default" do
      let name    = "db-default"
          version = 1
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version" do
      let name    = "db-specific"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version -> close -> open latest" do
      let name    = "db-latest"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      liftEff $ IDBDatabase.close db
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      tearDown name version db

    it "open + onUpgradeNeed" do
      let name    = "db-upgrade-needed"
          version = 1
          callback var db = do
            _ <- launchAff $ modifyVar (const $ IDBDatabase.name db) var
            pure unit
      var <- makeVar' "-"
      db  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db

    it "open + onBlocked" do
      let name    = "db-blocked"
          version = 14
          callback var = do
            _ <- launchAff $ modifyVar (const $ "db-blocked") var
            pure unit

      var   <- makeVar' "-"
      db01  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      _ <- forkAff do
        delay (Milliseconds 100.0)
        liftEff $ IDBDatabase.close db01

      db02  <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Just (callback var)
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db02

  describe "IDBDatabase" do
    it "createObjectStore (keyPath: [], autoIncrement: true)" do
      let dbName          = "db-create-store-01"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = []
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: true)" do
      let dbName          = "db-create-store-02"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"a\", \"b\"], autoIncrement: false)" do
      let dbName          = "db-create-store-03"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["a", "b"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: false)" do
      let dbName          = "db-create-store-04"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "deleteObjectStore" do
      let dbName           = "db-delete-store"
          dbVersion        = 2
          storeName        = "store"
          keyPath          = []
          autoIncrement    = true
          callback db      = do
            _ <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            pure unit
          callback2 var db = do
            _ <- IDBDatabase.deleteObjectStore db storeName
            _ <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      liftEff $ IDBDatabase.close db
      db  <- IDBFactory.open dbName (Just dbVersion)
        { onUpgradeNeeded : Just (callback2 var)
        , onBlocked       : Nothing
      }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

  describe "IDBObjectStore" do
    it "add(\"patate\", Nothing )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 1
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" Nothing)
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just 14 )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 14
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just \"key\" )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = "key"
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just <date> )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          mkey          = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let callback db   = do
                store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
                key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
                  <$> IDBObjectStore.add store "patate" (Just $ toKey key))
                pure unit

          db <- IDBFactory.open dbName Nothing
            { onUpgradeNeeded : Just callback
            , onBlocked       : Nothing
            }
          tearDown dbName dbVersion db

    it "add(\"patate\", Just [14, 42] )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = [14, 42]
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db


Remove slicey functions in favour of take/drop

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import charCodeAt
  "function charCodeAt(i) {\
  \  return function(s) {\
  \    return s.charCodeAt(i); \
  \  };\
  \}" :: Number -> String -> Number

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOf
  "function indexOf(x) {\
  \  return function(s) {\
  \    return s.indexOf(x);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOf
  "function lastIndexOf(x) {\
  \  return function(s) {\
  \    return s.lastIndexOf(x);\
  \  };\
  \}" :: String -> String -> Number

foreign import length
  "function length(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import take
  "function take(n) {\
  \  return function(s) {\
  \    return s.substr(0, n);\
  \  };\
  \}" :: Number -> String -> String

foreign import drop
  "function drop(n) {\
  \  return function(s) {\
  \    return s.substr(n);\
  \  };\
  \}" :: Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import charCodeAt
  "function charCodeAt(i) {\
  \  return function(s) {\
  \    return s.charCodeAt(i); \
  \  };\
  \}" :: Number -> String -> Number

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOf
  "function indexOf(x) {\
  \  return function(s) {\
  \    return s.indexOf(x);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOf
  "function lastIndexOf(x) {\
  \  return function(s) {\
  \    return s.lastIndexOf(x);\
  \  };\
  \}" :: String -> String -> Number

foreign import length
  "function length(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import slice
  "function slice(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String


Another doc fix

Another doc fix

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , setEncoding
  , onData
  , onDataString
  , onEnd
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  ) where

import Prelude

import Node.Encoding
import Node.Buffer (Buffer())
import Node.Buffer as Buffer

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # * -> # ! -> *

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import setEncodingImpl :: forall w eff. Readable w eff -> String -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream. This
-- | function is useful when you are passing a readable stream to some other
-- | JavaScript library, which already expects an encoding to be set. It
-- | has no effect on the behaviour of the `onDataString` function (because
-- | that function ensures that the encoding is always supplied explicitly).
setEncoding :: forall w eff. Readable w eff -> Encoding -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

foreign import onDataImpl :: forall w eff a. Readable w eff -> (a -> Eff eff Unit) -> Eff eff Unit

-- | Listen for `data` events, returning data in a Buffer.
onData :: forall w eff. Readable w eff -> (Buffer -> Eff eff Unit) -> Eff eff Unit
onData = onDataImpl

-- | Listen for `data` events, returning data in a String, which will be
-- | decoded using the given encoding.
onDataString :: forall w eff. Readable w eff -> Encoding -> (String -> Eff eff Unit) -> Eff eff Unit
onDataString r enc cb = onData r $ \buf -> do
  str <- unsafeInterleaveEff (Buffer.toString enc buf)
  cb str

-- | Listen for `end` events.
foreign import onEnd :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe :: forall r w eff. Readable w eff -> Writable r eff -> Eff eff (Writable r eff)

-- | Write a Buffer to a writable stream.
foreign import write :: forall r eff. Writable r eff -> Buffer -> Eff eff Unit -> Eff eff Boolean

foreign import writeStringImpl :: forall r eff. Writable r eff -> String -> String -> Eff eff Unit -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString :: forall r eff. Writable r eff -> Encoding -> String -> Eff eff Unit -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl :: forall r eff. Writable r eff -> String -> Eff eff Unit

-- | Set the default encoding used to write strings to the stream. This function
-- | is useful when you are passing a writable stream to some other JavaScript
-- | library, which already expects a default encoding to be set. It has no
-- | effect on the behaviour of the `writeString` function (because that
-- | function ensures that the encoding is always supplied explicitly).
setDefaultEncoding :: forall r eff. Writable r eff -> Encoding -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end :: forall r eff. Writable r eff -> Eff eff Unit -> Eff eff Unit

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , setEncoding
  , onData
  , onEnd
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  ) where

import Prelude

import Node.Encoding
import Node.Buffer (Buffer())
import Node.Buffer as Buffer

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # * -> # ! -> *

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import setEncodingImpl :: forall w eff. Readable w eff -> String -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream. This
-- | function is useful when you are passing a readable stream to some other
-- | JavaScript library, which already expects an encoding to be set. It
-- | has no effect on the behaviour of the `onDataString` function (because
-- | that function ensures that the encoding is always supplied explicitly).
setEncoding :: forall w eff. Readable w eff -> Encoding -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

foreign import onDataImpl :: forall w eff a. Readable w eff -> (a -> Eff eff Unit) -> Eff eff Unit

-- | Listen for `data` events, returning data in a Buffer.
onData :: forall w eff. Readable w eff -> (Buffer -> Eff eff Unit) -> Eff eff Unit
onData = onDataImpl

-- | Listen for `data` events, returning data in a String, which will be
-- | decoded using the given encoding.
onDataString :: forall w eff. Readable w eff -> Encoding -> (String -> Eff eff Unit) -> Eff eff Unit
onDataString r enc cb = onData r $ \buf -> do
  str <- unsafeInterleaveEff (Buffer.toString enc buf)
  cb str

-- | Listen for `end` events.
foreign import onEnd :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe :: forall r w eff. Readable w eff -> Writable r eff -> Eff eff (Writable r eff)

-- | Write a Buffer to a writable stream.
foreign import write :: forall r eff. Writable r eff -> Buffer -> Eff eff Unit -> Eff eff Boolean

foreign import writeStringImpl :: forall r eff. Writable r eff -> String -> String -> Eff eff Unit -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString :: forall r eff. Writable r eff -> Encoding -> String -> Eff eff Unit -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl :: forall r eff. Writable r eff -> String -> Eff eff Unit

-- | Set the default encoding used to write chunks to the stream. This function
-- | is useful when you are passing a writable stream to some other JavaScript
-- | library, which already expects a default encoding to be set. It has no
-- | effect on the behaviour of the `writeString` function (because that
-- | function ensures that the encoding is always supplied explicitly).
setDefaultEncoding :: forall r eff. Writable r eff -> Encoding -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end :: forall r eff. Writable r eff -> Eff eff Unit -> Eff eff Unit


Added connect'.

Added connect'.

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , StoreProvider(..)
  , storeProvider
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createClassStateless', createElement, forceUpdate, getProps, readState, writeState)
import React as R
import React.DOM (div')
import ReactHocs (CONTEXT, accessContext, getDisplayName, readContext, withContext, withContext')
import ReactHocs.DisplayName (setDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext { redox: RedoxContext { store, dispatch: dispatch_ store } } cls

newtype StoreProvider state dsl reff eff  = StoreProvider
  { store :: Store state
  , dispatch :: Store state -> DispatchFn state dsl reff eff
  }

-- | `StoreProvider` component.  This function provides store and the dispatch
-- | function through the React context.  This is an alternative to `withStore`
-- | function.
storeProvider :: forall state dsl reff eff. ReactClass (StoreProvider state dsl reff eff)
storeProvider = withContext'
    (case _ of StoreProvider { store, dispatch: dsp } -> { redox: RedoxContext { store, dispatch: dsp store } })
  $ setDisplayName "StoreProvider"
  $ createClassStateless' \_ children -> div' children

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or one of
    -- | `unsafeShallowEqual`, `unsafeStrictEqual` functions.
    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ st.state /= nSt.state || not (runFn3 unsafeShallowEqual true pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , StoreProvider(..)
  , storeProvider
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createClassStateless', createElement, forceUpdate, getProps, readState, writeState)
import React as R
import React.DOM (div')
import ReactHocs (CONTEXT, accessContext, getDisplayName, readContext, withContext, withContext')
import ReactHocs.DisplayName (setDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext { redox: RedoxContext { store, dispatch: dispatch_ store } } cls

newtype StoreProvider state dsl reff eff  = StoreProvider
  { store :: Store state
  , dispatch :: Store state -> DispatchFn state dsl reff eff
  }

-- | `StoreProvider` component.  This function provides store and the dispatch
-- | function through the React context.  This is an alternative to `withStore`
-- | function.
storeProvider :: forall state dsl reff eff. ReactClass (StoreProvider state dsl reff eff)
storeProvider = withContext'
    (case _ of StoreProvider { store, dispatch: dsp } -> { redox: RedoxContext { store, dispatch: dsp store } })
  $ setDisplayName "StoreProvider"
  $ createClassStateless' \_ children -> div' children

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or one of
    -- | `unsafeShallowEqual`, `unsafeStrictEqual` functions.
    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ st.state /= nSt.state || not (runFn3 unsafeShallowEqual true pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl


DispatchFn type - allow any redox effect

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId, WriteRedox)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (RedoxContext state dsl reff eff))
  -> Getter' state state'
  -> ((DispatchFn state dsl reff eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- (R.readState this)
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Getter' state state'
  -> (DispatchFn state dsl reff eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox) | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Getter' state state'
  -> (DispatchFn state dsl reff eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl reff eff
  -> Getter' state state'
  -> (DispatchFn state dsl reff eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox.Store (ReadRedox, ReadWriteRedox, RedoxStore, SubscribeRedox, Store, SubscriptionId, WriteRedox)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox) | eff) (Canceler (redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox) | eff))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox) | eff) (RedoxContext state dsl eff))
  -> Getter' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- (R.readState this)
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Getter' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox) | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl eff })) this

connect
  :: forall state state' dsl props props' eff'
   . Getter' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Getter' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, write :: WriteRedox, subscribe :: SubscribeRedox) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore ReadWriteRedox | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore ReadWriteRedox | eff))
dispatch this dsl = do
  _dispatch <- _.redox.dispatch <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this
  _dispatch dsl