connectToDispatch

connectToDispatch

A way to get access to the dispatch function from the context.

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

import Prelude

import Control.Monad.Aff (Canceler)
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(..))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
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) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring 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

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl 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 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: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (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

    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 $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false 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

-- | 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
   . Proxy state
  -> 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' _ _lns _iso cls = _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

connect
  :: forall state state' dsl props props' reff eff'
   . 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 = accessContext $ R.createClass $ connect' p _lns _iso cls

connectToDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectToDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (unsafeCoerce props').children

-- | 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 (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 )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {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 =
  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
  , withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
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, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

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

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring 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

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl this

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 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: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (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

    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 $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false 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

-- | 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
   . Proxy state
  -> 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' _ _lns _iso cls = _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

connect
  :: forall state state' dsl props props' reff eff'
   . 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 = accessContext $ R.createClass $ connect' p _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 (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 )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {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 =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl


withStore

withStore

* pass store once

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

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Canceler)
import Data.Maybe (Maybe(..))
import Data.Lens (Lens', view)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import React as R
import React (ReactClass, ReactSpec, ReactThis)
import Redox as Redox
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

-- | 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 -> dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch cls =
  withContext cls { redox: {store, dispatch store} }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

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

-- | 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 dsl eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' lns cnstrProps cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view lns state })

    getInitialState this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      state <- Redox.getState store
      pure { state: view lns state, sid: Nothing }

    componentWillMount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      msid <- R.readState this >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

    renderFn this = do
      props' <- R.getProps this
      state <- R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (cnstrProps state props') []

connect
  :: forall state state' props props'
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect lns cnstProps cls = accessContext $ R.createClass $ connect' lns cnstProps cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> dsl
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy (RedoxContext state dsl (context :: CONTEXT | eff)) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl

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

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Canceler)
import Data.Maybe (Maybe(..))
import Data.Lens (Lens', view)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import React as R
import React (ReactClass, ReactSpec, ReactThis)
import Redox as Redox
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

-- | 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
  -> (dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch cls =
  withContext cls { redox: {store, dispatch} }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

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

-- | 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 dsl eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' lns cnstrProps cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view lns state })

    getInitialState this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      state <- Redox.getState store
      pure { state: view lns state, sid: Nothing }

    componentWillMount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      msid <- R.readState this >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

    renderFn this = do
      props' <- R.getProps this
      state <- R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (cnstrProps state props') []

connect
  :: forall state state' props props'
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect lns cnstProps cls = accessContext $ R.createClass $ connect' lns cnstProps cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> dsl
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy (RedoxContext state dsl (context :: CONTEXT | eff)) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl


consistent type variable names

consistent type variable names

module ServerState where

import Debug.Trace (Trace(), trace)
import Data.Maybe
import Data.Tuple (fst, snd)
import Data.Foldable (for_)
import Data.Array (head, null, filter, (\\))
import qualified Data.Either as E
import qualified Data.String as S
import qualified Data.Map as M
import Data.Monoid (Monoid, mempty)
import Data.JSON (ToJSON, FromJSON, encode, eitherDecode)
import Control.Monad (when)
import Control.Monad.State (State(), runState)
import Control.Monad.Writer.Trans (WriterT(), runWriterT)
import Control.Monad.Writer.Class (MonadWriter, tell)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (newRef, readRef, writeRef, modifyRef, Ref(),
                              RefVal())
import Control.Reactive.Timer (Timer(), interval)
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import Types
import qualified NodeWebSocket as WS
import Utils (unionWith)

type Server st =
  { connections :: [Connection]
  , state :: st
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })

type Connection =
  { wsConn :: WS.Connection
  , pId :: PlayerId
  , name :: String
  }

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: [outg]
    , toOne :: M.Map PlayerId [outg]
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  (<>) (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

{-
Monad for server callbacks to run in. Rather than allowing Eff actions, we
just provide Writer and State as an interface to ask the server to do things.
This keeps all the game-specific server code pure! Hooray!

Note that, since you will usually want to send a bunch of outgoing messages at
a time, the type of message you're sending will end up being `[outg]` rather
than `outg`, so that's the type you should attempt to parse on the client.
-}
type ServerM st outg a =
  WriterT (SendMessages outg) (State st) a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st outg a.
  st -> ServerM st outg a -> ServerMResult st outg a
runServerM state action =
  let r1 = runWriterT action
      r2 = runState r1 state
  in { nextState: snd r2
     , messages: snd (fst r2)
     , result: fst (fst r2)
     }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  }

runCallback :: forall st outg args e. (ToJSON outg) =>
  RefVal (Server st) -> ServerM st outg Unit
  -> Eff (ref :: Ref, ws :: WS.WebSocket | e) Unit
runCallback refSrv callback = do
  srv <- readRef refSrv
  let res = runServerM srv.state callback
  sendAllMessages srv res.messages
  writeRef refSrv $ srv { state = res.nextState }

messagesFor :: forall outg. PlayerId -> SendMessages outg -> [outg]
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall e st outg. (ToJSON outg) =>
  Server st -> SendMessages outg
  -> Eff (ws :: WS.WebSocket | e) Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor conn.pId sm
    in when (not (null msgs)) $
      WS.send conn.wsConn (encode msgs)

sendUpdate :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  [outg] -> m Unit
sendUpdates ms =
  tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

stepsPerSecond = 30

type ServerEffects e =
  (timer :: Timer, ref :: Ref, trace :: Trace, ws :: WS.WebSocket | e)

startServer :: forall st inc outg e. (FromJSON inc, ToJSON outg) =>
  ServerCallbacks st inc outg -> RefVal (Server st)
  -> Eff (ServerEffects e) WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    trace "got a request"
    let playerName = S.drop 1 (WS.resourceUrl req).search

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            trace $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg ->
              case eitherDecode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> trace err
            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId
          Nothing -> do
            trace "rejecting connection, no player ids available"
            WS.close conn

  void $ interval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  return server

tryAddPlayer conn refSrv name = do
  srv <- readRef refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [{ pId: pId, wsConn: conn, name: name }] }
      writeRef refSrv srv'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c.pId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

closeConnection :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
closeConnection refSrv pId = do
  modifyRef refSrv $ connections %~ filter (\c -> pId /= c.pId)
  trace $ "closed connection for " <> show pId

module ServerState where

import Debug.Trace (Trace(), trace)
import Data.Maybe
import Data.Tuple (fst, snd)
import Data.Foldable (for_)
import Data.Array (head, null, filter, (\\))
import qualified Data.Either as E
import qualified Data.String as S
import qualified Data.Map as M
import Data.Monoid (Monoid, mempty)
import Data.JSON (ToJSON, FromJSON, encode, eitherDecode)
import Control.Monad (when)
import Control.Monad.State (State(), runState)
import Control.Monad.Writer.Trans (WriterT(), runWriterT)
import Control.Monad.Writer.Class (MonadWriter, tell)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (newRef, readRef, writeRef, modifyRef, Ref(),
                              RefVal())
import Control.Reactive.Timer (Timer(), interval)
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import Types
import qualified NodeWebSocket as WS
import Utils (unionWith)

type Server st =
  { connections :: [Connection]
  , state :: st
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })

type Connection =
  { wsConn :: WS.Connection
  , pId :: PlayerId
  , name :: String
  }

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: [outg]
    , toOne :: M.Map PlayerId [outg]
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  (<>) (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

{-
Monad for server callbacks to run in. Rather than allowing Eff actions, we
just provide Writer and State as an interface to ask the server to do things.
This keeps all the game-specific server code pure! Hooray!

Note that, since you will usually want to send a bunch of outgoing messages at
a time, the type of message you're sending will end up being `[outg]` rather
than `outg`, so that's the type you should attempt to parse on the client.
-}
type ServerM st outg a =
  WriterT (SendMessages outg) (State st) a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st fromsrv a.
  st -> ServerM st fromsrv a -> ServerMResult st fromsrv a
runServerM state action =
  let r1 = runWriterT action
      r2 = runState r1 state
  in { nextState: snd r2
     , messages: snd (fst r2)
     , result: fst (fst r2)
     }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  }

runCallback :: forall st outg args e. (ToJSON outg) =>
  RefVal (Server st) -> ServerM st outg Unit
  -> Eff (ref :: Ref, ws :: WS.WebSocket | e) Unit
runCallback refSrv callback = do
  srv <- readRef refSrv
  let res = runServerM srv.state callback
  sendAllMessages srv res.messages
  writeRef refSrv $ srv { state = res.nextState }

messagesFor :: forall outg. PlayerId -> SendMessages outg -> [outg]
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall e st outg. (ToJSON outg) =>
  Server st -> SendMessages outg
  -> Eff (ws :: WS.WebSocket | e) Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor conn.pId sm
    in when (not (null msgs)) $
      WS.send conn.wsConn (encode msgs)

sendUpdate :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  [outg] -> m Unit
sendUpdates ms =
  tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg. (Monad m, MonadWriter (SendMessages outg) m) =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

stepsPerSecond = 30

type ServerEffects e =
  (timer :: Timer, ref :: Ref, trace :: Trace, ws :: WS.WebSocket | e)

startServer :: forall st inc outg e. (FromJSON inc, ToJSON outg) =>
  ServerCallbacks st inc outg -> RefVal (Server st)
  -> Eff (ServerEffects e) WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    trace "got a request"
    let playerName = S.drop 1 (WS.resourceUrl req).search

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            trace $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg ->
              case eitherDecode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> trace err
            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId
          Nothing -> do
            trace "rejecting connection, no player ids available"
            WS.close conn

  void $ interval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  return server

tryAddPlayer conn refSrv name = do
  srv <- readRef refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [{ pId: pId, wsConn: conn, name: name }] }
      writeRef refSrv srv'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c.pId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

closeConnection :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
closeConnection refSrv pId = do
  modifyRef refSrv $ connections %~ filter (\c -> pId /= c.pId)
  trace $ "closed connection for " <> show pId


Type-level handler appending (no idea if it works)

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row

import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.Maybe (Maybe(..))
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj)
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

class ConsHandler (rin :: # Type) (rfun :: # Type) (l :: Symbol) a b (rin2 :: # Type) (rfun2 :: # Type)
      | rin l a -> rin2, rfun l a b -> rfun2

instance consHandler
         :: ( RowLacks l rin2
            , RowLacks l rfun2
            , RowCons l a rin1 rin2
            , RowCons l (a -> b) rfun1 rfun2
            )
         => ConsHandler rin rfun l a b rin2 rfun2

class AppendHandlerImpl (rin :: # Type) (rfun :: # Type) (l :: RowList) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil a b rin2 rfun2

instance appendHandlerCons
         :: ConsHandler rin rfun k a b rin2 rfun2
         => AppendHandlerImpl rin rfun (Cons k ty rest) a b rin2 rfun2

class AppendHandler (rin :: # Type) (rfun :: # Type) (l :: # Type) a b (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerInstance
         :: ( RowToList l llist
            , AppendHandlerImpl rin rfun llist a b rin2 rfun2
            )
         => AppendHandler rin rfun ls a b rin2 rfun2

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun eff.
               Union lt a rin
            => InputHandler rin rfun (Eff (avar :: AVAR | eff) Unit)
            -> BusRW (Variant lt)
            -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val

module Genetics.Browser.Events.Handler where

import Data.Record
import Prelude
import Type.Row

import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Rec.Class (forever)
import Data.Maybe (Maybe(..))
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, case_, expand, match, on, prj)
import Unsafe.Coerce (unsafeCoerce)

-- 'rin' is the row of types that this can handle,
-- 'rfun' is the row of types that corresponds to the record with functions
-- 'b' is the output type; all functions in 'rfun' must have 'b' as domain
data InputHandler (rin :: # Type) (rfun :: # Type) b = InputHandler (Record rfun)

appendHandler :: ∀ l a rin1 rin2 b rfun1 rfun2.
                 RowLacks l rin1
              => RowLacks l rfun1
              => RowCons l (a -> b) rfun1 rfun2
              => RowCons l a rin1 rin2
              => IsSymbol l
              => SProxy l
              -> (a -> b)
              -> InputHandler rin1 rfun1 b
              -> InputHandler rin2 rfun2 b
appendHandler l f (InputHandler r) = InputHandler $ insert l f r

emptyHandler :: ∀ b.
                InputHandler () () b
emptyHandler = InputHandler {}

applyHandler :: ∀ lt a rin rfun b.
                Union lt a rin
             => InputHandler rin rfun b
             -> Variant lt
             -> b
applyHandler (InputHandler h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

forkHandler :: ∀ lt a rin rfun.
               Union lt a rin
            => InputHandler rin rfun (Eff _ Unit)
            -> BusRW (Variant lt)
            -> _
forkHandler h bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyHandler h val


all me x values is NaN

all me x values is NaN

smh

module D3.ForceSimulation where

import Data.Pair
import D3.Base (Index, D3, Eff)
import D3.Selection (Selection)
import Data.Function.Eff (EffFn2, EffFn1, EffFn3, runEffFn1, runEffFn2, runEffFn3)
import Data.Function.Uncurried (mkFn2, Fn2)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (Unit)

foreign import data D3Simulation :: *
foreign import data D3Force      :: *

type Node = { id :: String, group :: Number }
type Link = { source :: String, target :: String, value :: Number }

type GroupedForceLayout = { nodes :: Array Node
                          , links :: Array Link }

-- for a type to be draggable it will have to have x and y fields for the drag callback to operate on
type ForceNode = { id :: String, group :: Number, x :: Number, y :: Number }
type ForceLink = { source :: ForceNode, target :: ForceNode, value :: Number }
type DraggableLayout = { nodes :: Array ForceNode
                       , links :: Array Link }

data ForceType      = Centering | Collision | Links | ManyBody | ForceX | ForceY
data SimulationType = Force

foreign import addForceFn          :: ∀ eff. EffFn3 (d3::D3|eff) String D3Force D3Simulation    D3Simulation
foreign import d3ForceSimulationFn :: ∀ eff. Eff    (d3::D3|eff)                                D3Simulation
foreign import linkIDFn            :: ∀ v eff. EffFn2 (d3::D3|eff) (Fn2 Node Index v) D3Force      D3Force
foreign import makeCenterForceFn   :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import makeCenterForceFnP  :: ∀ eff. EffFn1 (d3::D3|eff) (Array Number)                      D3Force
foreign import makeLinkForceFn     :: ∀ eff. EffFn1 (d3::D3|eff) (Array Link)                        D3Force
foreign import makeManyBodyForceFn :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import getLinksFn          :: ∀ eff. EffFn1 (d3::D3|eff) D3Simulation                   (Array Link)
foreign import setLinksFn          :: ∀ eff. EffFn2 (d3::D3|eff) (Array Link) D3Force                D3Force
foreign import getForceFn          :: ∀ eff. EffFn2 (d3::D3|eff) String       D3Simulation           D3Force
foreign import simulationNodesFn   :: ∀ eff. EffFn2 (d3::D3|eff) (Array Node) D3Simulation      D3Simulation
foreign import onTickFn            :: ∀ eff. EffFn2 (d3::D3|eff)
                                                    (Eff (d3::D3|eff) Unit)
                                                    D3Simulation
                                                    D3Simulation
foreign import defaultTickFn       :: ∀ eff. EffFn2 (d3::D3|eff) (Selection Node) (Selection Link)      Unit

defaultTick :: ∀ eff. Selection Node -> Selection Link -> Eff (d3::D3|eff) Unit
defaultTick = runEffFn2 defaultTickFn

d3ForceSimulation :: ∀ eff. SimulationType -> Eff (d3::D3|eff) D3Simulation
d3ForceSimulation Force = d3ForceSimulationFn

initNodes :: ∀ eff. Array Node -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
initNodes = runEffFn2 simulationNodesFn

onTick  :: forall eff. Eff (d3::D3|eff) Unit -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
onTick = runEffFn2 onTickFn

addForce :: ∀ eff. ForceType -> String -> D3Force -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
addForce Centering = runEffFn3 addForceFn
addForce Collision = runEffFn3 addForceFn -- "not implemented yet"
addForce Links     = runEffFn3 addForceFn
addForce ManyBody  = runEffFn3 addForceFn
addForce ForceX    = runEffFn3 addForceFn -- "not implemented yet"
addForce ForceY    = runEffFn3 addForceFn -- "not implemented yet"

-- This function will blow up if String doens't look up a valid force on this simulation TODO
getForce :: ∀ eff. String -> D3Simulation                         -> Eff (d3::D3|eff) D3Force
getForce name sim = runEffFn2 getForceFn name sim

-- || functions only for LINK force
makeLinkForce :: ∀ eff. Maybe (Array Link) -> Eff (d3::D3|eff) D3Force
makeLinkForce (Just ls) = runEffFn1 makeLinkForceFn   ls
makeLinkForce Nothing   = runEffFn1 makeLinkForceFn   []

setIDFunction :: ∀ v eff. (Node -> Index -> v) -> D3Force -> Eff (d3::D3|eff) D3Force -- Force HAS TO BE LINK FORCE HERE
setIDFunction f = runEffFn2 linkIDFn (mkFn2 f)

setLinks      :: ∀ eff. (Array Link) -> D3Force -> Eff (d3::D3|eff) D3Force
setLinks      = runEffFn2 setLinksFn

getLinks      :: ∀ eff. D3Simulation            -> Eff (d3::D3|eff) (Array Link)
getLinks      = runEffFn1 getLinksFn

-- || functions only for MANY BODY force
makeManyBody :: ∀ eff. Eff (d3::D3|eff) D3Force
makeManyBody = makeManyBodyForceFn

-- || functions only for CENTERING force
makeCenterForce :: ∀ eff. Maybe (Pair Number) -> Eff (d3::D3|eff) D3Force
makeCenterForce (Just (Pair x y)) = runEffFn1 makeCenterForceFnP [x,y]
makeCenterForce Nothing           = makeCenterForceFn

{-
Simulation API
  on
  find
  stop
  tick
  alpha
  force
  nodes
  restart
  alphaMin
  alphaDecay
  alphaTarget
  velocityDecay

Simulations typically compose multiple forces as desired. This module provides several for your enjoyment:

                x y radius strength iterations links id distance theta distanceMin distanceMax
  Centering     * *
  Collision           *       *         *
  Links                       *         *        *     *     *
  Many-Body                   *                                     *       *          *
  PositioningX  *             *
  PositioningY    *           *

  Constructors for forces
    Centering   [x,y]
    Collision   [radius]
    Links       [Links]
    ManyBody
    ForceX      [x]
    ForceY      [y]
-}

module D3.ForceSimulation where

import Data.Pair
import D3.Base (Index, D3, Eff)
import D3.Selection (Selection)
import Data.Foreign.Undefined (Undefined(Undefined), unUndefined)
import Data.Function.Eff (EffFn2, EffFn1, EffFn3, runEffFn1, runEffFn2, runEffFn3)
import Data.Function.Uncurried (mkFn2, Fn2)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (Unit, pure, bind)

foreign import data D3Simulation :: *
foreign import data D3Force      :: *

type Node = { id :: String, group :: Number }
type Link = { source :: String, target :: String, value :: Number }

type GroupedForceLayout = { nodes :: Array Node
                          , links :: Array Link }

-- for a type to be draggable it will have to have x and y fields for the drag callback to operate on
type ForceNode = { id :: String, group :: Number, x :: Number, y :: Number }
type ForceLink = { source :: ForceNode, target :: ForceNode, value :: Number }
type DraggableLayout = { nodes :: Array ForceNode
                       , links :: Array Link }

data ForceType      = Centering | Collision | Links | ManyBody | ForceX | ForceY
data SimulationType = Force

foreign import addForceFn          :: ∀ eff. EffFn3 (d3::D3|eff) String D3Force D3Simulation    D3Simulation
foreign import d3ForceSimulationFn :: ∀ eff. Eff    (d3::D3|eff)                                D3Simulation
foreign import linkIDFn            :: ∀ v eff. EffFn2 (d3::D3|eff) (Fn2 Node Index v) D3Force      D3Force
foreign import makeCenterForceFn   :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import makeCenterForceFnP  :: ∀ eff. EffFn1 (d3::D3|eff) (Array Number)                      D3Force
foreign import makeLinkForceFn     :: ∀ eff. EffFn1 (d3::D3|eff) (Array Link)                        D3Force
foreign import makeManyBodyForceFn :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import getLinksFn          :: ∀ eff. EffFn1 (d3::D3|eff) D3Simulation                   (Array Link)
foreign import setLinksFn          :: ∀ eff. EffFn2 (d3::D3|eff) (Array Link) D3Force                D3Force
foreign import getForceFn          :: ∀ eff. EffFn2 (d3::D3|eff) String       D3Simulation           D3Force
foreign import simulationNodesFn   :: ∀ eff. EffFn2 (d3::D3|eff) (Array Node) D3Simulation      D3Simulation
foreign import onTickFn            :: ∀ eff. EffFn2 (d3::D3|eff)
                                                    (Eff (d3::D3|eff) Unit)
                                                    D3Simulation
                                                    D3Simulation
foreign import defaultTickFn       :: ∀ eff. EffFn2 (d3::D3|eff) (Selection Node) (Selection Link)      Unit

defaultTick :: ∀ eff. Selection Node -> Selection Link -> Eff (d3::D3|eff) Unit
defaultTick = runEffFn2 defaultTickFn

d3ForceSimulation :: ∀ eff. SimulationType -> Eff (d3::D3|eff) D3Simulation
d3ForceSimulation Force = d3ForceSimulationFn

initNodes :: ∀ eff. Array Node -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
initNodes = runEffFn2 simulationNodesFn

onTick  :: forall eff. Eff (d3::D3|eff) Unit -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
onTick = runEffFn2 onTickFn

addForce :: ∀ eff. ForceType -> String -> D3Force -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
addForce Centering = runEffFn3 addForceFn
addForce Collision = runEffFn3 addForceFn -- "not implemented yet"
addForce Links     = runEffFn3 addForceFn
addForce ManyBody  = runEffFn3 addForceFn
addForce ForceX    = runEffFn3 addForceFn -- "not implemented yet"
addForce ForceY    = runEffFn3 addForceFn -- "not implemented yet"

-- This function will blow up if String doens't look up a valid force on this simulation TODO
getForce :: ∀ eff. String -> D3Simulation                         -> Eff (d3::D3|eff) D3Force
getForce name sim = runEffFn2 getForceFn name sim

-- || functions only for LINK force
makeLinkForce :: ∀ eff. Maybe (Array Link) -> Eff (d3::D3|eff) D3Force
makeLinkForce (Just ls) = runEffFn1 makeLinkForceFn   ls
makeLinkForce Nothing   = runEffFn1 makeLinkForceFn   []

setIDFunction :: ∀ v eff. (Node -> Index -> v) -> D3Force -> Eff (d3::D3|eff) D3Force -- Force HAS TO BE LINK FORCE HERE
setIDFunction f = runEffFn2 linkIDFn (mkFn2 f)

setLinks      :: ∀ eff. (Array Link) -> D3Force -> Eff (d3::D3|eff) D3Force
setLinks      = runEffFn2 setLinksFn

getLinks      :: ∀ eff. D3Simulation            -> Eff (d3::D3|eff) (Array Link)
getLinks      = runEffFn1 getLinksFn

-- || functions only for MANY BODY force
makeManyBody :: ∀ eff. Eff (d3::D3|eff) D3Force
makeManyBody = makeManyBodyForceFn

-- || functions only for CENTERING force
makeCenterForce :: ∀ eff. Maybe (Pair Number) -> Eff (d3::D3|eff) D3Force
makeCenterForce (Just (Pair x y)) = runEffFn1 makeCenterForceFnP [x,y]
makeCenterForce Nothing           = makeCenterForceFn

{-
Simulation API
  on
  find
  stop
  tick
  alpha
  force
  nodes
  restart
  alphaMin
  alphaDecay
  alphaTarget
  velocityDecay

Simulations typically compose multiple forces as desired. This module provides several for your enjoyment:

                x y radius strength iterations links id distance theta distanceMin distanceMax
  Centering     * *
  Collision           *       *         *
  Links                       *         *        *     *     *
  Many-Body                   *                                     *       *          *
  PositioningX  *             *
  PositioningY    *           *

  Constructors for forces
    Centering   [x,y]
    Collision   [radius]
    Links       [Links]
    ManyBody
    ForceX      [x]
    ForceY      [y]
-}


Rework the Monoid explanation when referring to its newtypes

module Data.Monoid
  ( class Monoid, mempty
  , power
  , guard
  , module Data.Semigroup
  , class MonoidRecord, memptyRecord
  ) where

import Data.Boolean (otherwise)
import Data.Eq ((==))
import Data.EuclideanRing (mod, (/))
import Data.Ord ((<=))
import Data.Ordering (Ordering(..))
import Data.Semigroup (class Semigroup, class SemigroupRecord, (<>))
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | A `Monoid` is a `Semigroup` with a value `mempty`, which is both a
-- | left and right unit for the associative operation `<>`:
-- |
-- | - Left unit: `(mempty <> x) = x`
-- | - Right unit: `(x <> mempty) = x`
-- |
-- | `Monoid`s are commonly used as the result of fold operations, where
-- | `<>` is used to combine individual results, and `mempty` gives the result
-- | of folding an empty collection of elements.
-- |
-- | ### Newtypes for Monoid
-- |
-- | Some types (e.g. `Int`, `Boolean`) can implement multiple law-abiding
-- | instances for `Monoid`. Let's use `Int` as an example
-- | 1. `<>` could be `+` and `mempty` could be `0`
-- | 2. `<>` could be `*` and `mempty` could be `1`.
-- |
-- | To clarify these ambiguous situations, one should use the newtypes
-- | defined in `Data.Monoid.<NewtypeName>` modules.
-- |
-- | In the above ambiguous situation, we could use `Additive`
-- | for the first situation or `Multiplicative` for the second one.
class Semigroup m <= Monoid m where
  mempty :: m

instance monoidUnit :: Monoid Unit where
  mempty = unit

instance monoidOrdering :: Monoid Ordering where
  mempty = EQ

instance monoidFn :: Monoid b => Monoid (a -> b) where
  mempty _ = mempty

instance monoidString :: Monoid String where
  mempty = ""

instance monoidArray :: Monoid (Array a) where
  mempty = []

instance monoidRecord :: (RL.RowToList row list, MonoidRecord list row row) => Monoid (Record row) where
  mempty = memptyRecord (RLProxy :: RLProxy list)

-- | Append a value to itself a certain number of times. For the
-- | `Multiplicative` type, and for a non-negative power, this is the same as
-- | normal number exponentiation.
-- |
-- | If the second argument is negative this function will return `mempty`
-- | (*unlike* normal number exponentiation). The `Monoid` constraint alone
-- | is not enough to write a `power` function with the property that `power x
-- | n` cancels with `power x (-n)`, i.e. `power x n <> power x (-n) = mempty`.
-- | For that, we would additionally need the ability to invert elements, i.e.
-- | a Group.
power :: forall m. Monoid m => m -> Int -> m
power x = go
  where
  go :: Int -> m
  go p
    | p <= 0 = mempty
    | p == 1 = x
    | p `mod` 2 == 0 = let x' = go (p / 2) in x' <> x'
    | otherwise = let x' = go (p / 2) in x' <> x' <> x

-- | Allow or "truncate" a Monoid to its `mempty` value based on a condition.
guard :: forall m. Monoid m => Boolean -> m -> m
guard true a = a
guard false _ = mempty

-- | A class for records where all fields have `Monoid` instances, used to
-- | implement the `Monoid` instance for records.
class SemigroupRecord rowlist row subrow <= MonoidRecord rowlist row subrow | rowlist -> row subrow where
  memptyRecord :: RLProxy rowlist -> Record subrow

instance monoidRecordNil :: MonoidRecord RL.Nil row () where
  memptyRecord _ = {}

instance monoidRecordCons
    :: ( IsSymbol key
       , Monoid focus
       , Row.Cons key focus subrowTail subrow
       , MonoidRecord rowlistTail row subrowTail
       )
    => MonoidRecord (RL.Cons key focus rowlistTail) row subrow where
  memptyRecord _
    = insert mempty tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = memptyRecord (RLProxy :: RLProxy rowlistTail)

module Data.Monoid
  ( class Monoid, mempty
  , power
  , guard
  , module Data.Semigroup
  , class MonoidRecord, memptyRecord
  ) where

import Data.Boolean (otherwise)
import Data.Eq ((==))
import Data.EuclideanRing (mod, (/))
import Data.Ord ((<=))
import Data.Ordering (Ordering(..))
import Data.Semigroup (class Semigroup, class SemigroupRecord, (<>))
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | A `Monoid` is a `Semigroup` with a value `mempty`, which is both a
-- | left and right unit for the associative operation `<>`:
-- |
-- | - Left unit: `(mempty <> x) = x`
-- | - Right unit: `(x <> mempty) = x`
-- |
-- | `Monoid`s are commonly used as the result of fold operations, where
-- | `<>` is used to combine individual results, and `mempty` gives the result
-- | of folding an empty collection of elements.
-- |
-- | ### Newtypes for Monoid
-- |
-- | Some types (e.g. `Int`, `Boolean`) can implement multiple law-abiding
-- | instances for `Monoid`. For example, `<>` could be `+` and `mempty` could
-- | be `0`. Likewise, `<>` could be `*` and `mempty` could be `1`.
-- | To workaround these ambiguous situations, one should use newtypes
-- | to specify which instance should be used:
-- | - `Additive`: use `Semiring`'s `plus`/`+` and `zero` for `<>` and `mempty`.
-- | - `Multiplicative`: use `Semiring`'s `mul`/`*` and `one` for `<>` and `mempty`.
-- | - `Conj`: use `HeytingAlgebra`'s `conj`/`&&` and `tt` for `<>` and `mempty`.
-- | - `Disj`: use `HeytingAlgebra`'s `disj`/`||` and `ff` for `<>` and `mempty`.
-- | - `Endo`: use `Category`'s `compose`/`<<<` and `identity` for `<>` and `mempty`.
-- | - `Dual`: use `Category`'s `composeFlipped`/`>>>` and `identity` for `<>` and `mempty`.
class Semigroup m <= Monoid m where
  mempty :: m

instance monoidUnit :: Monoid Unit where
  mempty = unit

instance monoidOrdering :: Monoid Ordering where
  mempty = EQ

instance monoidFn :: Monoid b => Monoid (a -> b) where
  mempty _ = mempty

instance monoidString :: Monoid String where
  mempty = ""

instance monoidArray :: Monoid (Array a) where
  mempty = []

instance monoidRecord :: (RL.RowToList row list, MonoidRecord list row row) => Monoid (Record row) where
  mempty = memptyRecord (RLProxy :: RLProxy list)

-- | Append a value to itself a certain number of times. For the
-- | `Multiplicative` type, and for a non-negative power, this is the same as
-- | normal number exponentiation.
-- |
-- | If the second argument is negative this function will return `mempty`
-- | (*unlike* normal number exponentiation). The `Monoid` constraint alone
-- | is not enough to write a `power` function with the property that `power x
-- | n` cancels with `power x (-n)`, i.e. `power x n <> power x (-n) = mempty`.
-- | For that, we would additionally need the ability to invert elements, i.e.
-- | a Group.
power :: forall m. Monoid m => m -> Int -> m
power x = go
  where
  go :: Int -> m
  go p
    | p <= 0 = mempty
    | p == 1 = x
    | p `mod` 2 == 0 = let x' = go (p / 2) in x' <> x'
    | otherwise = let x' = go (p / 2) in x' <> x' <> x

-- | Allow or "truncate" a Monoid to its `mempty` value based on a condition.
guard :: forall m. Monoid m => Boolean -> m -> m
guard true a = a
guard false _ = mempty

-- | A class for records where all fields have `Monoid` instances, used to
-- | implement the `Monoid` instance for records.
class SemigroupRecord rowlist row subrow <= MonoidRecord rowlist row subrow | rowlist -> row subrow where
  memptyRecord :: RLProxy rowlist -> Record subrow

instance monoidRecordNil :: MonoidRecord RL.Nil row () where
  memptyRecord _ = {}

instance monoidRecordCons
    :: ( IsSymbol key
       , Monoid focus
       , Row.Cons key focus subrowTail subrow
       , MonoidRecord rowlistTail row subrowTail
       )
    => MonoidRecord (RL.Cons key focus rowlistTail) row subrow where
  memptyRecord _
    = insert mempty tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = memptyRecord (RLProxy :: RLProxy rowlistTail)