withStore: make it effectful

withStore: make it effectful

This way dispatch effects can be unified.

module React.Redox
  ( ConnectState
  , withStore
  , connect'
  , connect
  , withDispatch
  , 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(Just, Nothing))
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 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

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 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 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    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 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.
-- |
-- | 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

-- | Like `connect'` but for `ReactClass`-es.
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

-- | 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') (unsafeCoerce props').children

-- | Light weight 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 explicitly 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

-- | If you wrapped your component with `connect` or `connect'` you can use
-- | this `dispatch` function to run your actions.
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
  , withDispatch
  , 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(Just, Nothing))
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 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

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 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
  -> 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    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 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.
-- |
-- | 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

-- | Like `connect'` but for `ReactClass`-es.
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

-- | 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') (unsafeCoerce props').children

-- | Light weight 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 explicitly 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

-- | If you wrapped your component with `connect` or `connect'` you can use
-- | this `dispatch` function to run your actions.
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


Update Lazy.purs (#36)

Update Lazy.purs (#36)

Improve accuracy of the description of the force function.

module Data.Lazy where

import Prelude

import Control.Comonad (class Comonad)
import Control.Extend (class Extend)
import Control.Lazy as CL
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.Functor.Invariant (class Invariant, imapF)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.HeytingAlgebra (implies, ff, tt)
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Semigroup.Traversable (class Traversable1)
import Data.Traversable (class Traversable, traverse)
import Data.TraversableWithIndex (class TraversableWithIndex)

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: Type -> Type

type role Lazy representational

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Extract the result of a `Lazy` value by either forcing evaluation or
-- | by retrieving the saved result of a previously forced evaluation.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: Semiring a => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: Ring a => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance commutativeRingLazy :: CommutativeRing a => CommutativeRing (Lazy a)

instance euclideanRingLazy :: EuclideanRing a => EuclideanRing (Lazy a) where
  degree = degree <<< force
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance eqLazy :: Eq a => Eq (Lazy a) where
  eq x y = (force x) == (force y)

derive instance eq1Lazy :: Eq1 Lazy

instance ordLazy :: Ord a => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

derive instance ord1Lazy :: Ord1 Lazy

instance boundedLazy :: Bounded a => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance semigroupLazy :: Semigroup a => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: Monoid a => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance heytingAlgebraLazy :: HeytingAlgebra a => HeytingAlgebra (Lazy a) where
  ff = defer \_ -> ff
  tt = defer \_ -> tt
  implies a b = implies <$> a <*> b
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance booleanAlgebraLazy :: BooleanAlgebra a => BooleanAlgebra (Lazy a)

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance functorWithIndexLazy :: FunctorWithIndex Unit Lazy where
  mapWithIndex f = map $ f unit

instance foldableLazy :: Foldable Lazy where
  foldr f z l = f (force l) z
  foldl f z l = f z (force l)
  foldMap f l = f (force l)

instance foldableWithIndexLazy :: FoldableWithIndex Unit Lazy where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldable1Lazy :: Foldable1 Lazy where
  foldMap1 f l = f (force l)
  foldr1 _ l = force l
  foldl1 _ l = force l

instance traversableLazy :: Traversable Lazy where
  traverse f l = defer <<< const <$> f (force l)
  sequence l = defer <<< const <$> force l

instance traversableWithIndexLazy :: TraversableWithIndex Unit Lazy where
  traverseWithIndex f = traverse $ f unit

instance traversable1Lazy :: Traversable1 Lazy where
  traverse1 f l = defer <<< const <$> f (force l)
  sequence1 l = defer <<< const <$> force l

instance invariantLazy :: Invariant Lazy where
  imap = imapF

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f (force x)

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force $ f (force l)

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: Show a => Show (Lazy a) where
  show x = "(defer \\_ -> " <> show (force x) <> ")"

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)

module Data.Lazy where

import Prelude

import Control.Comonad (class Comonad)
import Control.Extend (class Extend)
import Control.Lazy as CL
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.Functor.Invariant (class Invariant, imapF)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.HeytingAlgebra (implies, ff, tt)
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Semigroup.Traversable (class Traversable1)
import Data.Traversable (class Traversable, traverse)
import Data.TraversableWithIndex (class TraversableWithIndex)

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: Type -> Type

type role Lazy representational

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Force evaluation of a `Lazy` value.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: Semiring a => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: Ring a => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance commutativeRingLazy :: CommutativeRing a => CommutativeRing (Lazy a)

instance euclideanRingLazy :: EuclideanRing a => EuclideanRing (Lazy a) where
  degree = degree <<< force
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance eqLazy :: Eq a => Eq (Lazy a) where
  eq x y = (force x) == (force y)

derive instance eq1Lazy :: Eq1 Lazy

instance ordLazy :: Ord a => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

derive instance ord1Lazy :: Ord1 Lazy

instance boundedLazy :: Bounded a => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance semigroupLazy :: Semigroup a => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: Monoid a => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance heytingAlgebraLazy :: HeytingAlgebra a => HeytingAlgebra (Lazy a) where
  ff = defer \_ -> ff
  tt = defer \_ -> tt
  implies a b = implies <$> a <*> b
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance booleanAlgebraLazy :: BooleanAlgebra a => BooleanAlgebra (Lazy a)

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance functorWithIndexLazy :: FunctorWithIndex Unit Lazy where
  mapWithIndex f = map $ f unit

instance foldableLazy :: Foldable Lazy where
  foldr f z l = f (force l) z
  foldl f z l = f z (force l)
  foldMap f l = f (force l)

instance foldableWithIndexLazy :: FoldableWithIndex Unit Lazy where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldable1Lazy :: Foldable1 Lazy where
  foldMap1 f l = f (force l)
  foldr1 _ l = force l
  foldl1 _ l = force l

instance traversableLazy :: Traversable Lazy where
  traverse f l = defer <<< const <$> f (force l)
  sequence l = defer <<< const <$> force l

instance traversableWithIndexLazy :: TraversableWithIndex Unit Lazy where
  traverseWithIndex f = traverse $ f unit

instance traversable1Lazy :: Traversable1 Lazy where
  traverse1 f l = defer <<< const <$> f (force l)
  sequence1 l = defer <<< const <$> force l

instance invariantLazy :: Invariant Lazy where
  imap = imapF

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f (force x)

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force $ f (force l)

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: Show a => Show (Lazy a) where
  show x = "(defer \\_ -> " <> show (force x) <> ")"

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)


fix typo in doc (#275)

fix typo in doc (#275)

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` because no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the keyword `void` that commonly appears in
-- | C-family languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the `void` of C-family languages above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the keyword `void` that commonly appears in
-- | C-family languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the `void` of C-family languages above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b


Remove unnecessary $

Remove unnecessary $

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import CoreFn.Module (Module(..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, dir, dir', file, printPath, runDirName, (</>))
import Data.String as S
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) = for_ trie \(Trie.Path path) ->
  case Array.unsnoc path of
    Just { init, last } -> do
      log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
      let
        enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
        decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
      log $ prettyPrint decl <> "\n"
    Nothing -> pure unit

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) (Array Trie.Path)
toPaths = foldr acc (pure [])
  where
    acc
      :: String
      -> Aff (Effects eff) (Array Trie.Path)
      -> Aff (Effects eff) (Array Trie.Path)
    acc filename modulePaths = do
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        hidden :: Boolean
        hidden = maybe false (S.singleton >>> (_ == ".")) $ S.charAt 0 filename

        when
          :: Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        when true m = m
        when false _ = modulePaths

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        whenM mb m = do
          b <- mb
          when b m

      when (not hidden) do
        stat <- stat $ printPath moduleDir

        when (isDirectory stat) do
          let filepath = printPath $ moduleDir </> file "corefn.json"

          whenM (exists filepath) do
            coreFn <- readTextFile UTF8 filepath
            case runExcept (moduleFromJSON coreFn) of
              Left e ->
                -- trace ("Left: " <> show e) \_->
                modulePaths
              Right { module: (Module module_) } ->
                -- trace ("Right: " <> show module_.moduleForeign) \_ ->
                let
                  { moduleForeign, moduleName } = module_
                  hasForeign = not Array.null moduleForeign
                  modulePath = Trie.Path $ map unwrap $ unwrap moduleName
                  foreignPaths = guard hasForeign [modulePath <> Trie.Path ["_Foreign"]]
                  paths = [modulePath] <> foreignPaths
                in
                  pure paths <> modulePaths

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  paths <- toPaths files
  let trie = fromPaths paths
  liftEff $ dryRun trie

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import CoreFn.Module (Module(..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, dir, dir', file, printPath, runDirName, (</>))
import Data.String as S
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) = for_ trie \(Trie.Path path) ->
  case Array.unsnoc path of
    Just { init, last } -> do
      log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
      let
        enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
        decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
      log $ prettyPrint decl <> "\n"
    Nothing -> pure unit

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) (Array Trie.Path)
toPaths = foldr acc (pure [])
  where
    acc
      :: String
      -> Aff (Effects eff) (Array Trie.Path)
      -> Aff (Effects eff) (Array Trie.Path)
    acc filename modulePaths = do
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        hidden :: Boolean
        hidden = maybe false (S.singleton >>> (_ == ".")) $ S.charAt 0 filename

        when
          :: Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        when true m = m
        when false _ = modulePaths

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        whenM mb m = do
          b <- mb
          when b m

      when (not hidden) do
        stat <- stat $ printPath moduleDir

        when (isDirectory stat) do
          let filepath = printPath $ moduleDir </> file "corefn.json"

          whenM (exists filepath) do
            coreFn <- readTextFile UTF8 $ filepath
            case runExcept (moduleFromJSON coreFn) of
              Left e ->
                -- trace ("Left: " <> show e) \_->
                modulePaths
              Right { module: (Module module_) } ->
                -- trace ("Right: " <> show module_.moduleForeign) \_ ->
                let
                  { moduleForeign, moduleName } = module_
                  hasForeign = not Array.null moduleForeign
                  modulePath = Trie.Path $ map unwrap $ unwrap moduleName
                  foreignPaths = guard hasForeign [modulePath <> Trie.Path ["_Foreign"]]
                  paths = [modulePath] <> foreignPaths
                in
                  pure paths <> modulePaths

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  paths <- toPaths files
  let trie = fromPaths paths
  liftEff $ dryRun trie


Removed connectStore: it is unsafe (breaking change)

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , 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, createElement, forceUpdate, 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) (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 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    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)
-- | ```
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
  -> 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'
   . 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
  , 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, createElement, forceUpdate, 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) (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 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    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)
-- | ```
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
  -> 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'
   . 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)

-- | Light weight 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 explicitly 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

-- | 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


Get rid of notPossible hack

Get rid of notPossible hack

module App.Board where

import Matrix as Matrix
import CSS (inline)
import Data.Function ((#))
import Data.Maybe (fromJust)
import Matrix (Matrix)
import Partial.Unsafe (unsafePartial)
import Prelude (($), show, map, bind)
import Pux.CSS (display, em, padding, rgb, backgroundColor, style)
import Pux.Html (Html, div, text)

data Action = Reset | Move Player

type Cell = Int

type State =
  { cells :: Matrix Cell
  , nextMove :: Player }

data Player = A | B

playerACells :: State -> Array Cell
playerACells state = unsafePartial fromJust $ Matrix.getRow 0 state.cells

playerBCells :: State -> Array Cell
playerBCells state = unsafePartial fromJust $ Matrix.getRow 1 state.cells

init :: State
init =
  { cells: Matrix.repeat 7 2 0
  , nextMove: A }

update :: Action -> State -> State
update Reset state = init
update (Move player) state = state

view :: State -> Html Action
view state =
  div []
  [ div [] $ map viewCell $ playerACells state
  , div [] [ text "sep" ] -- XXX: remove this ugly display hack
  , div [] $ map viewCell $ playerBCells state
  ]

viewCell :: Cell -> Html Action
viewCell count =
  div [s] [ text $ show count ]
  where
    s = style $ do
      display inline
      backgroundColor (rgb 200 100 0)
      squarePadding (1.0 # em)
    squarePadding sz = padding sz sz sz sz

module App.Board where

import Matrix as Matrix
import CSS (inline)
import Data.Function ((#))
import Data.Maybe (fromMaybe)
import Matrix (Matrix)
import Prelude (($), show, map, bind)
import Pux.CSS (display, em, padding, rgb, backgroundColor, style)
import Pux.Html (Html, div, span, text)

data Action = Reset | Move Player

type Cell = Int

type State =
  { cells :: Matrix Cell
  , nextMove :: Player }

data Player = A | B

notPossible :: Array Cell
notPossible = [99, 99, 99, 99, 99, 99, 99]

init :: State
init =
  { cells: Matrix.repeat 7 2 0
  , nextMove: A }

update :: Action -> State -> State
update Reset state = init
update (Move player) state = state

view :: State -> Html Action
view state =
  div []
  [ div [] $ map viewCell $ row 0
  , div [] [ text "sep" ] -- XXX: remove this ugly display hack
  , div [] $ map viewCell $ row 1
  ]
  where
    row n = fromMaybe notPossible $ Matrix.getRow n state.cells

viewCell :: Cell -> Html Action
viewCell count =
  div [s] [ text $ show count ]
  where
    s = style $ do
      display inline
      backgroundColor (rgb 200 100 0)
      squarePadding (1.0 # em)
    squarePadding sz = padding sz sz sz sz


Fix test build for new purescript-test-unit

module Test.Main where

import Prelude
import Data.List as List
import Test.Unit.Assert as Assert
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Data.Either (isLeft, Either(Right))
import Data.Foldable (intercalate)
import Suggest (replaceFile')
import Test.Unit (test, suite)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)

main :: forall e. Eff (avar :: AVAR, console :: CONSOLE, testOutput :: TESTOUTPUT | e) Unit
main = runTest do
  suite "suggestions" do
    test "replace multi-line" do
      let replacements = replace (List.singleton (testReplacement 2 3 "REPLACEMENT"))
      Assert.equal (result [ "Line 1", "REPLACEMENT", "Line 4", "Line 5" ]) replacements
    test "replace single-line" do
      let replacements = replace (List.singleton (testReplacement 2 2 "REPLACEMENT"))
      Assert.equal (result [ "Line 1", "REPLACEMENT", "Line 3", "Line 4", "Line 5" ]) replacements
    test "2 replacements with gap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 2 "TEXT1", testReplacement 4 4 "TEXT2"])
      Assert.equal (result [ "Line 1", "TEXT1", "Line 3", "TEXT2", "Line 5" ]) replacements
    test "2 replacements with no gap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 3 "TEXT1", testReplacement 4 4 "TEXT2"])
      Assert.equal (result [ "Line 1", "TEXT1", "TEXT2", "Line 5" ]) replacements
    test "replacement after end of file" do
      let replacements = replace (List.fromFoldable [testReplacement 10 20 "ERROR"])
      Assert.assert "should be Left" $ isLeft replacements
    test "replacements overlap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 4 "TEXT1", testReplacement 3 5 "TEXT2"])
      Assert.assert "should be Left" $ isLeft replacements
  suite "suggestions within a line" do
    test "suggestion within single line" do
      let replacements = replace (List.singleton (testReplacement' 2 2 2 4 "_"))
      Assert.equal (result [ "Line 1", "L_e 2", "Line 3", "Line 4", "Line 5" ]) replacements
    test "suggestions across multiple lines" do
      let replacements = replace (List.singleton (testReplacement' 2 2 3 4 "_"))
      Assert.equal (result [ "Line 1", "L_e 3", "Line 4", "Line 5" ]) replacements
    test "multiple suggestions on one line" do
      let replacements = replace (List.fromFoldable [testReplacement' 2 1 2 2 "_", testReplacement' 2 4 2 6 "_"])
      Assert.equal (result [ "Line 1", "_in_2", "Line 3", "Line 4", "Line 5" ]) replacements

  where
  -- psc line indexing is 1-based
  replace x = intercalate "" <$> replaceFile' 1 1 (List.fromFoldable testFile) x
  result = Right <<< intercalate "\n"
  testFile = [
      "Line 1"
    , "Line 2"
    , "Line 3"
    , "Line 4"
    , "Line 5"
  ]
  testFileName = "/path/to/my/file.purs"

  testReplacement startLine endLine replacement =
    { filename: testFileName
    , position: { startLine, startColumn: 1, endLine, endColumn: 7 }
    , original: "I think this is unused"
    , replacement
    }

  testReplacement' startLine startColumn endLine endColumn replacement =
    { filename: testFileName
    , position: { startLine, startColumn, endLine, endColumn }
    , original: "I think this is unused"
    , replacement
    }

module Test.Main where

import Prelude
import Data.List as List
import Test.Unit.Assert as Assert
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Either (isLeft, Either(Right))
import Data.Foldable (intercalate)
import Suggest (replaceFile')
import Test.Unit (test, suite)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)

main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT | e) Unit
main = runTest do
  suite "suggestions" do
    test "replace multi-line" do
      let replacements = replace (List.singleton (testReplacement 2 3 "REPLACEMENT"))
      Assert.equal (result [ "Line 1", "REPLACEMENT", "Line 4", "Line 5" ]) replacements
    test "replace single-line" do
      let replacements = replace (List.singleton (testReplacement 2 2 "REPLACEMENT"))
      Assert.equal (result [ "Line 1", "REPLACEMENT", "Line 3", "Line 4", "Line 5" ]) replacements
    test "2 replacements with gap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 2 "TEXT1", testReplacement 4 4 "TEXT2"])
      Assert.equal (result [ "Line 1", "TEXT1", "Line 3", "TEXT2", "Line 5" ]) replacements
    test "2 replacements with no gap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 3 "TEXT1", testReplacement 4 4 "TEXT2"])
      Assert.equal (result [ "Line 1", "TEXT1", "TEXT2", "Line 5" ]) replacements
    test "replacement after end of file" do
      let replacements = replace (List.fromFoldable [testReplacement 10 20 "ERROR"])
      Assert.assert "should be Left" $ isLeft replacements
    test "replacements overlap" do
      let replacements = replace (List.fromFoldable [testReplacement 2 4 "TEXT1", testReplacement 3 5 "TEXT2"])
      Assert.assert "should be Left" $ isLeft replacements
  suite "suggestions within a line" do
    test "suggestion within single line" do
      let replacements = replace (List.singleton (testReplacement' 2 2 2 4 "_"))
      Assert.equal (result [ "Line 1", "L_e 2", "Line 3", "Line 4", "Line 5" ]) replacements
    test "suggestions across multiple lines" do
      let replacements = replace (List.singleton (testReplacement' 2 2 3 4 "_"))
      Assert.equal (result [ "Line 1", "L_e 3", "Line 4", "Line 5" ]) replacements
    test "multiple suggestions on one line" do
      let replacements = replace (List.fromFoldable [testReplacement' 2 1 2 2 "_", testReplacement' 2 4 2 6 "_"])
      Assert.equal (result [ "Line 1", "_in_2", "Line 3", "Line 4", "Line 5" ]) replacements

  where
  -- psc line indexing is 1-based
  replace x = intercalate "" <$> replaceFile' 1 1 (List.fromFoldable testFile) x
  result = Right <<< intercalate "\n"
  testFile = [
      "Line 1"
    , "Line 2"
    , "Line 3"
    , "Line 4"
    , "Line 5"
  ]
  testFileName = "/path/to/my/file.purs"

  testReplacement startLine endLine replacement =
    { filename: testFileName
    , position: { startLine, startColumn: 1, endLine, endColumn: 7 }
    , original: "I think this is unused"
    , replacement
    }

  testReplacement' startLine startColumn endLine endColumn replacement =
    { filename: testFileName
    , position: { startLine, startColumn, endLine, endColumn }
    , original: "I think this is unused"
    , replacement
    }


add specs for IDBDatabase methods

add specs for IDBDatabase methods

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.Maybe                        (Maybe(..))
import Data.Time.Duration                (Milliseconds(..))
import Test.Spec                         (describe, it)
import Test.Spec.Assertions              (shouldEqual)
import Test.Spec.Mocha                   (MOCHA, runMocha)

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

tearDown :: forall eff. String -> Int -> IDBDatabase -> 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

module Test.Main where

import Prelude

import Data.Time.Duration             (Milliseconds(..))
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.Maybe                     (Maybe(..))
import Test.Spec                      (describe, it, itOnly)
import Test.Spec.Assertions           (shouldEqual)
import Test.Spec.Mocha                (MOCHA, runMocha)

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

tearDown :: forall eff. String -> Int -> IDBDatabase -> 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


Better names for constants

Better names for constants

module Main where

import Control.Monad.Eff
import Data.Array
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Graphics.Canvas
import Math
import Prelude

type Player = String

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if disj (conj (even x) (odd y)) (conj (even y) (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = conj (y < layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        hasPlayerTwo = conj (y >= height - layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else if hasPlayerTwo
                then Just { color: colorPlayerTwo }
                else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  save ctx
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  restore ctx
  case square.piece of
    Just piece -> do
      save ctx
      setFillStyle piece.color ctx
      fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                               y: square.ry + 0.5 * renderSize,
                               r: (renderSize / 2.0) * 0.8,
                               start: 0.0,
                               end: 2.0 * pi }
      restore ctx
      return unit
    _ -> return unit

render :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
render ctx grid = do
  save ctx
  foldM (renderSquare ctx) unit grid.squares
  restore ctx
  save ctx
  setStrokeStyle "black" ctx
  strokeRect ctx { x: 0.5,
                   y: 0.5,
                   w: (toNumber grid.width) * renderSize,
                   h: (toNumber grid.height) * renderSize }
  restore ctx
  return unit

main :: forall e. Eff (canvas :: Canvas | e) Unit
main = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx (createGrid 8 8 3)
      return unit
    _ -> return unit

module Main where

import Control.Monad.Eff
import Data.Array
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Graphics.Canvas
import Math
import Prelude

type Player = String

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorOne = "red"
colorTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if disj (conj (even x) (odd y)) (conj (even y) (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = conj (y < layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        hasPlayerTwo = conj (y >= height - layers) (disj (conj (even y) (odd x)) (conj (even x) (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorOne }
                else if hasPlayerTwo
                then Just { color: colorTwo }
                else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  save ctx
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  restore ctx
  case square.piece of
    Just piece -> do
      save ctx
      setFillStyle piece.color ctx
      fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                               y: square.ry + 0.5 * renderSize,
                               r: (renderSize / 2.0) * 0.8,
                               start: 0.0,
                               end: 2.0 * pi }
      restore ctx
      return unit
    _ -> return unit

render :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
render ctx grid = do
  save ctx
  foldM (renderSquare ctx) unit grid.squares
  restore ctx
  save ctx
  setStrokeStyle "black" ctx
  strokeRect ctx { x: 0.5,
                   y: 0.5,
                   w: (toNumber grid.width) * renderSize,
                   h: (toNumber grid.height) * renderSize }
  restore ctx
  return unit

main :: forall e. Eff (canvas :: Canvas | e) Unit
main = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx (createGrid 8 8 3)
      return unit
    _ -> return unit


Adding function for scraping enabled cards from page

module Main (main) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, css, JQuery(..), ready, select)

import Data.Array(filter)
import Data.Foldable(for_)
import Data.Map(fromList, lookup)
import Data.Maybe(Maybe(..))
import Data.Tuple(Tuple(..))

import AppState(AppState(..))
import Cards(Card(..), cards)
import DOM(DOM(..))
import Element(genCardCheckbox)
import JQueryUI(accordion, attrStr, button, buttonset, change, children, click, each, flipChecked, refreshButton, siblings, spinner, tabs, val)

main = ready $ do
  initJQUI
  AppState { cardHolder = cardHolder } <- initState
  cleanupCSS
  populateCardSetCustomizer cardHolder

initJQUI :: forall eff. Eff (dom :: DOM | eff) JQuery
initJQUI = do
  select ".collapsible-accordion" >>= (accordion { heightStyle: "fill" })
  select ".ui-spinner-button"     >>= click spinAButton
  foreach ".ui-button"    mkButton
  foreach ".ui-tabs"      mkTabs
  foreach ".ui-spinner"   spinIt
  foreach ".checkboxes"   mkButtonSet
  foreach ".check-set"    mkButtonSet
  foreach ".radio-set"    mkButtonSet
  foreach ".check-button" mkButton
  foreach ".check-label"  checkIt
    where
      foreach x f = select x >>= each f
      checkIt     = click innerClick
      mkButton    = button
      mkButtonSet = buttonset
      mkTabs      = tabs
      spinAButton this = do
                           sibs <- siblings "input" this
                           change sibs
      spinIt this = do
                      spinner this
                      val "1" this

cleanupCSS :: forall eff. Eff (dom :: DOM | eff) JQuery
cleanupCSS = do
  mainBox <- byID "main-box"
  css { overflow: "auto" } mainBox

initState :: forall eff. Eff (dom :: DOM | eff) AppState
initState = do
  adderButtonElem    <- byID "adder-button"
  adderTableElem     <- byID "adder-table"
  cardHolderElem     <- byID "card-holder"
  cardNumSpinnerElem <- byID "card-num-spinner"
  nameInputElem      <- byID "name-input"
  pickButtonElem     <- byID "pick-btn"
  return $ AppState { adderButton:    adderButtonElem
                    , adderTable:     adderTableElem
                    , cardHolder:     cardHolderElem
                    , cardNumSpinner: cardNumSpinnerElem
                    , nameInput:      nameInputElem
                    , pickButton:     pickButtonElem
                    , playerNums:     []
                    }

populateCardSetCustomizer :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
populateCardSetCustomizer cardHolder = do
  for_ cards $ appendCard cardHolder
  foreach ".dynamic-check-button" button
  foreach ".dynamic-check-label"  innerClick
    where
      foreach x f = children x cardHolder >>= f
      appendCard elem (Card { name = name, isEnabled = isEnabled }) =
        genCardCheckbox name isEnabled >>= flip append elem

innerClick :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
innerClick this = do
  forAttr <- attrStr "for" this
  btn     <- byID forAttr
  flipChecked btn
  refreshButton btn
  change btn

findEnabledCards :: forall eff. JQuery -> Eff (dom :: DOM | eff) [Card]
findEnabledCards cardHolder = do
  labels <- children "label" cardHolder
  pairs  <- mapLabelsToPairs labels
  let labelEnabledMap = fromList pairs
  return $ filter (checkCardIsEnabled labelEnabledMap) cards
    where
      checkCardIsEnabled lookupMap (Card { name = name }) = (lookup name lookupMap) == Just true

-- .map(...).get()
foreign import mapLabelsToPairs
  """
  function button(ob) {
    return function() {
      var arr = ob.map(function() {
        var elem      = jQuery(this);
        var id        = elem.attr("for");
        var name      = elem.text();
        var isEnabled = $("#" + id)[0].checked;
        return PS.Data_Tuple.create(name)(isEnabled);
      }).get();
      return arr;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) [Tuple String Boolean]

filterM :: forall a m. (Monad m) => (a -> m Boolean) -> [a] -> m [a]
filterM _ []     = return []
filterM p (x:xs) = do
   pred <- p x
   ys   <- filterM p xs
   return $ if pred then x:ys else ys

byID :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
byID id = select $ "#" ++ id

(|>) a f = f a

module Main (main) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, css, JQuery(..), ready, select)

import Data.Foldable(for_)

import AppState(AppState(..))
import Cards(Card(..), cards)
import DOM(DOM(..))
import Element(genCardCheckbox)
import JQueryUI(accordion, attrStr, button, buttonset, change, children, click, each, flipChecked, refreshButton, siblings, spinner, tabs, val)

main = ready $ do
  initJQUI
  AppState { cardHolder = cardHolder } <- initState
  cleanupCSS
  populateCardSetCustomizer cardHolder

initJQUI :: forall eff. Eff (dom :: DOM | eff) JQuery
initJQUI = do
  select ".collapsible-accordion" >>= (accordion { heightStyle: "fill" })
  select ".ui-spinner-button"     >>= click spinAButton
  foreach ".ui-button"    mkButton
  foreach ".ui-tabs"      mkTabs
  foreach ".ui-spinner"   spinIt
  foreach ".checkboxes"   mkButtonSet
  foreach ".check-set"    mkButtonSet
  foreach ".radio-set"    mkButtonSet
  foreach ".check-button" mkButton
  foreach ".check-label"  checkIt
    where
      foreach x f = select x >>= each f
      checkIt     = click innerClick
      mkButton    = button
      mkButtonSet = buttonset
      mkTabs      = tabs
      spinAButton this = do
                           sibs <- siblings "input" this
                           change sibs
      spinIt this = do
                      spinner this
                      val "1" this

cleanupCSS :: forall eff. Eff (dom :: DOM | eff) JQuery
cleanupCSS = do
  mainBox <- byID "main-box"
  css { overflow: "auto" } mainBox

initState :: forall eff. Eff (dom :: DOM | eff) AppState
initState = do
  adderButtonElem    <- byID "adder-button"
  adderTableElem     <- byID "adder-table"
  cardHolderElem     <- byID "card-holder"
  cardNumSpinnerElem <- byID "card-num-spinner"
  nameInputElem      <- byID "name-input"
  pickButtonElem     <- byID "pick-btn"
  return $ AppState { adderButton:    adderButtonElem
                    , adderTable:     adderTableElem
                    , cardHolder:     cardHolderElem
                    , cardNumSpinner: cardNumSpinnerElem
                    , nameInput:      nameInputElem
                    , pickButton:     pickButtonElem
                    , playerNums:     []
                    }

populateCardSetCustomizer :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
populateCardSetCustomizer cardHolder = do
  for_ cards $ appendCard cardHolder
  foreach ".dynamic-check-button" button
  foreach ".dynamic-check-label"  innerClick
    where
      foreach x f = children x cardHolder >>= f
      appendCard elem (Card { name = name, isEnabled = isEnabled }) =
        genCardCheckbox name isEnabled >>= flip append elem

innerClick :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
innerClick this = do
  forAttr <- attrStr "for" this
  btn     <- byID forAttr
  flipChecked btn
  refreshButton btn
  change btn

filterM :: forall a m. (Monad m) => (a -> m Boolean) -> [a] -> m [a]
filterM _ []     = return []
filterM p (x:xs) = do
   pred <- p x
   ys   <- filterM p xs
   return $ if pred then x:ys else ys

byID :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
byID id = select $ "#" ++ id

(|>) a f = f a