RedoxSpec: wrap ReactSpec in a newtype.

RedoxSpec: wrap ReactSpec in a newtype.

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , 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, createClass, createClassStateless', 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 -> Array ReactElement -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    -- using createClassStateless' ensures that children are coerced to `Array ReactElement`
    cls :: ctx -> ReactClass props
    cls ctx = createClassStateless' \props children -> fn props children ctx

    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\props { ctx } -> createElement (cls ctx) props (unsafeCoerce props).children)

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' children { redox: RedoxContext { dispatch: disp }} -> createElement cls (fn disp 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, createClassStateless', 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 -> Array ReactElement -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    -- using createClassStateless' ensures that children are coerced to `Array ReactElement`
    cls :: ctx -> ReactClass props
    cls ctx = createClassStateless' \props children -> fn props children ctx

    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\props { ctx } -> createElement (cls ctx) props (unsafeCoerce props).children)

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' children { redox: RedoxContext { dispatch: disp }} -> createElement cls (fn disp 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


Remove comment, reformat function a little, fix missing guard on case

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar, putVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.Monad.Fork (fork)
import Control.UI.Browser as Browser
import Data.Coyoneda (liftCoyoneda)
import Data.List as List
import Data.Time.Duration (Milliseconds(..))
import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM
import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify, cpDialog)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Common as DeckCommon
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Dialog.Component as Dialog
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))
import SlamData.Workspace.StateMode as StateMode
import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    [ header
    , deck
    , notifications
    , cardGuide
    , flipGuide
    , dialogSlot
    ]
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
    HH.button
      [ HE.onClick $ HE.input_ $ SignIn providerR
      , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  cardGuide =
    if state.guide ≡ Just CardGuide
      then HH.div_ [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]
      else HH.text ""

  flipGuide =
    if state.guide ≡ Just FlipGuide
      then HH.div_ [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]
      else HH.text ""

  dialogSlot =
    HH.slot' cpDialog unit Dialog.component unit (HE.input HandleDialog)

  notifications =
    HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (HE.input HandleNotification)

  header =
    if AT.isEditable accessType
      then HH.slot' cpHeader unit Header.component unit absurd
      else HH.text ""

  deck =
    case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { auth, bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) auth.signIn
    H.subscribe $ busEventSource (flip HandleWorkspace ES.Listening) bus.workspace
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    H.gets _.cursor >>= List.head >>> traverse_ \deckId → do
      eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
      when eq $ Wiring.focusDeck deckId
    pure next
  Resize reply → do
    _ ← queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      _ ← fork $ runFreshWorkspace mempty
      initializeGuides
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      _ ← fork $ runFreshWorkspace
        [ CM.Open (Just (Open.Resource (R.File res)))
        , CM.Table JT.emptyModel
        ]
      initializeGuides
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    initializeGuides
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        LS.persist LSK.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        LS.persist LSK.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next
  HandleNotification msg next →
    handleNotification msg $> next
  HandleSignInMessage msg next → do
    stateMode ← H.gets _.stateMode
    when
      (msg ≡ GlobalMenu.SignInSuccess ∧ StateMode.isError stateMode)
      (H.liftEff Browser.reload)
    pure next
  HandleWorkspace (Wiring.ShowDialog dlg) next →
    H.query' cpDialog unit (H.action (Dialog.Show dlg)) $> next
  HandleDialog msg next →
    handleDialog msg $> next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }
    for_ (List.head cursor') Wiring.focusDeck

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  Wiring.focusDeck deckId
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  _ ← H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

initializeGuides ∷ WorkspaceDSL Unit
initializeGuides = do
  { bus, accessType } ← H.lift Wiring.expose
  initialCardGuideStep >>= case _ of
    Nothing → do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    Just ix → when (AT.isEditable accessType) do
      void $ H.query' cpGuide CardGuide $ H.action $ Guide.SetActiveStep ix
      H.modify _ { guide = Just CardGuide }

handleNotification ∷ NC.Action → WorkspaceDSL Unit
handleNotification = case _ of
  NC.ExpandGlobalMenu → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
  NC.Fulfill var →
    void $ H.liftAff $ Aff.attempt $ putVar var unit

handleDialog ∷ Dialog.Message → WorkspaceDSL Unit
handleDialog = case _ of
  Dialog.Confirm opts d b → case d of
    Dialog.Rename opts' name | b → do
      void $ H.lift $ P.renameDeck opts'.deckId name
      Wiring.switchDeckToFront opts'
    Dialog.DeleteDeck opts' | b → do
      Wiring.switchDeckToFlip opts'
      H.lift $ DeckCommon.deleteDeck opts'
    _ →
      Wiring.switchDeckToFlip opts
  Dialog.Dismissed →
    pure unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

queryHeaderGripper ∷ ∀ a. Gripper.Query a → WorkspaceDSL (Maybe a)
queryHeaderGripper =
   H.query' cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LS.retrieve LSK.dismissedCardGuideKey

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar, putVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.Monad.Fork (fork)
import Control.UI.Browser as Browser
import Data.Coyoneda (liftCoyoneda)
import Data.List as List
import Data.Time.Duration (Milliseconds(..))
import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM
import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify, cpDialog)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Common as DeckCommon
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Dialog.Component as Dialog
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))
import SlamData.Workspace.StateMode as StateMode
import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    [ header
    , deck
    , notifications
    , cardGuide
    , flipGuide
    , dialogSlot
    ]
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
    HH.button
      [ HE.onClick $ HE.input_ $ SignIn providerR
      , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  cardGuide =
    if state.guide ≡ Just CardGuide
      then HH.div_ [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]
      else HH.text ""

  flipGuide =
    if state.guide ≡ Just FlipGuide
      then HH.div_ [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]
      else HH.text ""

  dialogSlot =
    HH.slot' cpDialog unit Dialog.component unit (HE.input HandleDialog)

  notifications =
    HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (HE.input HandleNotification)

  header =
    if AT.isEditable accessType
      then HH.slot' cpHeader unit Header.component unit absurd
      else HH.text ""

  deck =
    case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { auth, bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) auth.signIn
    H.subscribe $ busEventSource (flip HandleWorkspace ES.Listening) bus.workspace
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    H.gets _.cursor >>= List.head >>> traverse_ \deckId → do
      eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
      when eq $ Wiring.focusDeck deckId
    pure next
  Resize reply → do
    _ ← queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      _ ← fork $ runFreshWorkspace mempty
      initializeGuides
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      _ ← fork $ runFreshWorkspace
        [ CM.Open (Just (Open.Resource (R.File res)))
        , CM.Table JT.emptyModel
        ]
      initializeGuides
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    initializeGuides
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        LS.persist LSK.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        LS.persist LSK.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next
  HandleNotification msg next →
    handleNotification msg $> next
  HandleSignInMessage msg next → do
    stateMode ← H.gets _.stateMode
    when
      (msg ≡ GlobalMenu.SignInSuccess ∧ StateMode.isError stateMode)
      (H.liftEff Browser.reload)
    pure next
  HandleWorkspace (Wiring.ShowDialog dlg) next →
    H.query' cpDialog unit (H.action (Dialog.Show dlg)) $> next
  HandleDialog msg next →
    handleDialog msg $> next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }
    for_ (List.head cursor') Wiring.focusDeck

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  Wiring.focusDeck deckId
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  _ ← H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

initializeGuides ∷ WorkspaceDSL Unit
initializeGuides = do
  { bus, accessType } ← H.lift Wiring.expose
  initialCardGuideStep >>= case _ of
    Nothing → do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    Just ix → when (AT.isEditable accessType) do
      void $ H.query' cpGuide CardGuide $ H.action $ Guide.SetActiveStep ix
      H.modify _ { guide = Just CardGuide }

handleNotification ∷ NC.Action → WorkspaceDSL Unit
handleNotification = case _ of
  NC.ExpandGlobalMenu → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
  NC.Fulfill var →
    void $ H.liftAff $ Aff.attempt $ putVar var unit

handleDialog ∷ Dialog.Message → WorkspaceDSL Unit
handleDialog = case _ of
  Dialog.Confirm opts d b → do
    case d of
      Dialog.Rename opts' name → do
        void $ H.lift $ P.renameDeck opts'.deckId name
        Wiring.switchDeckToFront opts'
      Dialog.DeleteDeck opts' | b → do
        Wiring.switchDeckToFlip opts'
        H.lift $ DeckCommon.deleteDeck opts'
      _ → do
        Wiring.switchDeckToFlip opts
    -- queryDialog $ H.action Dialog.Dismiss
  Dialog.Dismissed →
    pure unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

queryHeaderGripper ∷ ∀ a. Gripper.Query a → WorkspaceDSL (Maybe a)
queryHeaderGripper =
   H.query' cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LS.retrieve LSK.dismissedCardGuideKey


Remove unused import

Remove unused import

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Trans

type StateData s a = { state :: s, value :: a }

data StateT s m a = StateT (s -> m (StateData s a))

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return { state: s, value: a }
  (>>=) (StateT x) f = StateT \s -> do
    { state = s', value = v } <- x s
    runStateT (f v) s'

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return { state: s, value: x }

runStateT :: forall s m a. StateT s m a -> s -> m (StateData s a)
runStateT (StateT s) = s

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Identity
import Control.Monad.Trans

type StateData s a = { state :: s, value :: a }

data StateT s m a = StateT (s -> m (StateData s a))

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return { state: s, value: a }
  (>>=) (StateT x) f = StateT \s -> do
    { state = s', value = v } <- x s
    runStateT (f v) s'

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return { state: s, value: x }

runStateT :: forall s m a. StateT s m a -> s -> m (StateData s a)
runStateT (StateT s) = s

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f


fix example

fix example

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Data.Foldable (sequence_)

import Neovim.Buffer (setLines)
import Neovim.Plugin (command, commandSync, defaultOpts, Args, Range, PLUGIN)
import Neovim.Types (Nvim)
import Neovim.Nvim (getCurrentBuf)

main :: forall e. Eff (plugin :: PLUGIN | e) Unit
main = sequence_ [ commandSync "HelloPurescriptSync" defaultOpts helloCmdSync
                 , command "HelloPurescript" defaultOpts helloCmd
                 ]

helloCmdSync :: forall e. Nvim -> Args -> Range -> Aff (plugin :: PLUGIN | e) Unit
helloCmdSync nvim args range = getCurrentBuf nvim >>= \b -> setLines b 0 1 true ["Hi back! (sync)"]

helloCmd :: forall e. Nvim -> Args -> Range -> Aff (plugin :: PLUGIN | e) Unit
helloCmd nvim args range = getCurrentBuf nvim >>= \b -> setLines b 0 1 true ["Hi back!"]

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Data.Foldable (sequence_)

import Neovim.Buffer (setLine)
import Neovim.Plugin (command, commandSync, defaultOpts, Args, Range, PLUGIN)
import Neovim.Types (Vim)
import Neovim.Vim (getCurrentBuffer)

main :: forall e. Eff (plugin :: PLUGIN | e) Unit
main = sequence_ [ commandSync "HelloPurescriptSync" defaultOpts helloCmdSync
                 , command "HelloPurescript" defaultOpts helloCmd
                 ]

helloCmdSync :: forall e. Vim -> Args -> Range -> Aff (plugin :: PLUGIN | e) Unit
helloCmdSync vim args range = getCurrentBuffer vim >>= \b -> setLine b 0 "Hi back! (sync)"

helloCmd :: forall e. Vim -> Args -> Range -> Aff (plugin :: PLUGIN | e) Unit
helloCmd vim args range = getCurrentBuffer vim >>= \b -> setLine b 0 "Hi back!"


Update for STArray changes

Update for STArray changes

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST as STA
import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Record as Record
import Data.String (charCodeAt, fromCharArray, split)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Data.RowList (RLProxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NES.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- STA.unsafeThaw xs
        _ <- STA.push x mxs
        STA.unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep. Generic a rep => Coarbitrary rep => a -> Gen a -> Gen a
genericCoarbitrary x g = to <$> coarbitrary (from x) (from <$> g)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: RLProxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (RLProxy :: RLProxy listRest)
     pure $ Record.insert (SProxy :: SProxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (RLProxy :: RLProxy list)

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST (pushSTArray, unsafeFreeze, unsafeThaw)
import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Record as Record
import Data.String (charCodeAt, fromCharArray, split)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Data.RowList (RLProxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NES.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- unsafeThaw xs
        _ <- pushSTArray mxs x
        unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep. Generic a rep => Coarbitrary rep => a -> Gen a -> Gen a
genericCoarbitrary x g = to <$> coarbitrary (from x) (from <$> g)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: RLProxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (RLProxy :: RLProxy listRest)
     pure $ Record.insert (SProxy :: SProxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (RLProxy :: RLProxy list)


Revise for (:) move to Prelude

Revise for (:) move to Prelude

module Data.Traversable where

import Prelude
import Data.Array (zipWith)
import Data.Either
import Data.Eq
import Data.Foldable
import Data.Maybe
import Data.Tuple

class Traversable t where
  traverse :: forall a b m. (Functor m, Applicative m) => (a -> m b) -> t a -> m (t b)
  sequence :: forall a m. (Functor m, Applicative m) => t (m a) -> m (t a)

instance traversableArray :: Traversable [] where
  traverse _ []     = pure []
  traverse f (x:xs) = (:) <$> (f x) <*> traverse f xs

  sequence []     = pure []
  sequence (x:xs) = (:) <$> x <*> sequence xs

instance traversableEither :: Traversable (Either a) where
  traverse _ (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x

  sequence (Left x) = pure (Left x)
  sequence (Right x)  = Right <$> x

instance traversableRef :: Traversable Ref where
  traverse f (Ref x) = Ref <$> f x

  sequence (Ref x) = Ref <$> x

instance traversableMaybe :: Traversable Maybe where
  traverse _ Nothing  = pure Nothing
  traverse f (Just x) = Just <$> f x

  sequence Nothing  = pure Nothing
  sequence (Just x) = Just <$> x

instance traversableTuple :: Traversable (Tuple a) where
  traverse f (Tuple x y) = Tuple x <$> f y

  sequence (Tuple x y) = Tuple x <$> y

for :: forall a b m t. (Functor m, Applicative m, Traversable t) => t a -> (a -> m b) -> m (t b)
for x f = traverse f x

zipWithA :: forall m a b c. (Functor m, Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithA f xs ys = sequence (zipWith f xs ys)

module Data.Traversable where

import Prelude
import Data.Array ((:), zipWith)
import Data.Either
import Data.Eq
import Data.Foldable
import Data.Maybe
import Data.Tuple

class Traversable t where
  traverse :: forall a b m. (Functor m, Applicative m) => (a -> m b) -> t a -> m (t b)
  sequence :: forall a m. (Functor m, Applicative m) => t (m a) -> m (t a)

instance traversableArray :: Traversable [] where
  traverse _ []     = pure []
  traverse f (x:xs) = (:) <$> (f x) <*> traverse f xs

  sequence []     = pure []
  sequence (x:xs) = (:) <$> x <*> sequence xs

instance traversableEither :: Traversable (Either a) where
  traverse _ (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x

  sequence (Left x) = pure (Left x)
  sequence (Right x)  = Right <$> x

instance traversableRef :: Traversable Ref where
  traverse f (Ref x) = Ref <$> f x

  sequence (Ref x) = Ref <$> x

instance traversableMaybe :: Traversable Maybe where
  traverse _ Nothing  = pure Nothing
  traverse f (Just x) = Just <$> f x

  sequence Nothing  = pure Nothing
  sequence (Just x) = Just <$> x

instance traversableTuple :: Traversable (Tuple a) where
  traverse f (Tuple x y) = Tuple x <$> f y

  sequence (Tuple x y) = Tuple x <$> y

for :: forall a b m t. (Functor m, Applicative m, Traversable t) => t a -> (a -> m b) -> m (t b)
for x f = traverse f x

zipWithA :: forall m a b c. (Functor m, Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithA f xs ys = sequence (zipWith f xs ys)


Fix AlphaNumString

Fix AlphaNumString

module Test.StrongCheck.Data.AlphaNumString where

import Prelude

import Data.String as S

import Test.StrongCheck.Arbitrary (class Arbitrary, class Coarbitrary, coarbitrary)
import Test.StrongCheck.Gen (arrayOf, oneOf)

newtype AlphaNumString = AlphaNumString String

runAlphaNumString :: AlphaNumString -> String
runAlphaNumString (AlphaNumString s) = s

derive instance eqAlphaNumString :: Eq AlphaNumString
derive instance ordAlphaNumString :: Ord AlphaNumString

instance arbAlphaNumString :: Arbitrary AlphaNumString where
  arbitrary = AlphaNumString <<< S.fromCharArray <$> arrayOf anyChar
    where
    rest = S.toCharArray "bcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    anyChar = oneOf (pure 'a') (map pure rest)

instance coarbAlphaNumString :: Coarbitrary AlphaNumString where
  coarbitrary (AlphaNumString s) = coarbitrary s

module Test.StrongCheck.Data.AlphaNumString where

import Prelude

import Data.Maybe (fromJust)
import Data.String as S
import Data.Traversable (sequence)

import Partial.Unsafe (unsafePartial)

import Test.StrongCheck.Arbitrary (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)

newtype AlphaNumString = AlphaNumString String

runAlphaNumString :: AlphaNumString -> String
runAlphaNumString (AlphaNumString s) = s

derive instance eqAlphaNumString :: Eq AlphaNumString
derive instance ordAlphaNumString :: Ord AlphaNumString

instance arbAlphaNumString :: Arbitrary AlphaNumString where
  arbitrary = unsafePartial do
    arrNum <- arbitrary
    pure $ fromJust $ (AlphaNumString <<< S.fromCharArray) <$> sequence (lookup <$> arrNum)
    where
    chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    lookup x = S.charAt index chars
      where
      index =
        let
          i1 = S.length chars - 1
          i2 = x * S.length chars
        in if i1 < i2 then i1 else i2

instance coarbAlphaNumString :: Coarbitrary AlphaNumString where
  coarbitrary (AlphaNumString s) = coarbitrary s


Updated tests.

Updated tests.

module Test.ServerSideRendering where

import Control.Comonad.Cofree (Cofree, exploreM, unfoldCofree)
import Control.Monad.Aff (Aff, Fiber)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Free (Free, liftF)
import Data.Lens (to)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype, over)
import Prelude (class Functor, Unit, bind, const, discard, id, pure, unit, void, ($), (<$>))
import React (ReactClass, createClass, createClassStateless, createElement, getProps, spec)
import React.DOM (div', text)
import React.Redox (connect, withStore)
import ReactDOM (renderToString)
import Redox (CreateRedox, RedoxStore, Store, ReadWriteRedox, mkStore)
import Redox (dispatch) as Redox
import Test.Unit (TestSuite, suite, test)
import Test.Unit.Assert (equal)
import Type.Proxy (Proxy(..))

data Command a
  = PutMsg String a
  | Reset a

derive instance functorCommand :: Functor Command

putMsg :: forall a. String -> Free Command (a -> a)
putMsg msg = liftF (PutMsg msg id)

reset :: forall a. Free Command (a -> a)
reset = liftF (Reset id)

newtype Run eff a = Run
  { putMsg :: String -> Aff eff a
  , reset :: Aff eff a
  }

derive instance functorRun :: Functor (Run eff)

newtype State = State { msg :: Maybe String }

derive instance newtypeState :: Newtype State _

mkInterp :: forall eff. State -> Cofree (Run eff) State
mkInterp state = unfoldCofree id next state
  where
    next :: State -> Run eff State
    next st = Run
      { putMsg: \msg -> pure $ over State (_ { msg = (Just msg) }) st
      , reset: pure $ over State (_ { msg = Nothing } ) st
      }

pair :: forall eff x y. Command (x -> y) -> Run eff x -> Aff eff y
pair (PutMsg msg next) (Run i) = next <$> (i.putMsg msg)
pair (Reset next) (Run i) = next <$> i.reset

runInterp :: forall eff. Store State -> Free Command (State -> State) -> State -> Aff eff State
runInterp store cmds state = exploreM pair cmds (mkInterp state)

testSuite :: forall e. TestSuite (redox :: RedoxStore (create :: CreateRedox) | e)
testSuite =
  suite "server side rendering"
    let
      disp
        :: forall e1
         . Store State
        -> Free Command (State -> State)
        -> Eff
            ( redox :: RedoxStore ReadWriteRedox | e1)
            (Fiber ( redox :: RedoxStore ReadWriteRedox | e1) Unit)
      disp store = Redox.dispatch (const $ pure unit) (runInterp store) store

      cls :: ReactClass { msg :: Maybe String }
      cls = createClass (spec unit renderCls)
      renderCls this = do
        { msg } <- getProps this
        let msg_ = fromMaybe "" msg
        pure (div' [ text msg_ ])

      connCls :: ReactClass Unit
      connCls = connect
        (Proxy :: Proxy State)
        (to (case _ of State { msg } -> msg))
        (\_ msg _ -> { msg })
        cls
    in do
      test "connect"
        do
          str <- liftEff do
            store <- mkStore (State { msg: Just "hello" })
            top <- withStore store disp (createClassStateless \_ -> createElement connCls unit [])
            pure $ renderToString (createElement top unit [])
          equal str """
hello
"""

      test "componentWillMount" do
        str <- liftEff do
          store <- mkStore (State { msg: Nothing })
          let

            topSpec = (spec unit renderTop)
              { componentWillMount = componentWillMount
              , componentDidMount = componentDidMount
              }

            renderTop _ = pure $ createElement connCls unit []

            componentWillMount _ = do
              -- is called
              void $ disp store (putMsg "hello")

            componentDidMount _ = do
              -- is not called
              void $ disp store reset

          top <- withStore store disp (createClass topSpec)
          pure $ renderToString (createElement top unit [])
        equal str """
hello
"""

module Test.ServerSideRendering where

import Control.Comonad.Cofree (Cofree, exploreM, unfoldCofree)
import Control.Monad.Aff (Aff, Fiber)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Free (Free, liftF)
import Data.Lens (to)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype, over, un)
import Prelude (class Functor, Unit, bind, const, discard, id, pure, unit, void, ($), (<$>))
import React (ReactClass, createClass, createClassStateless, createElement, getProps, spec)
import React.DOM (div', text)
import React.Redox (connect, withStore)
import ReactDOM (renderToString)
import Redox (CreateRedox, RedoxStore, Store, ReadWriteRedox, mkStore)
import Redox (dispatch) as Redox
import Test.Unit (TestSuite, suite, test)
import Test.Unit.Assert (equal)
import Type.Proxy (Proxy(..))

data Command a
  = PutMsg String a
  | Reset a

derive instance functorCommand :: Functor Command

putMsg :: forall a. String -> Free Command (a -> a)
putMsg msg = liftF (PutMsg msg id)

reset :: forall a. Free Command (a -> a)
reset = liftF (Reset id)

newtype Run eff a = Run
  { putMsg :: String -> Aff eff a
  , reset :: Aff eff a
  }

derive instance functorRun :: Functor (Run eff)

newtype State = State { msg :: Maybe String }

derive instance newtypeState :: Newtype State _

mkInterp :: forall eff. State -> Cofree (Run eff) State
mkInterp state = unfoldCofree id next state
  where
    next :: State -> Run eff State
    next st = Run
      { putMsg: \msg -> pure $ over State (_ { msg = (Just msg) }) st
      , reset: pure $ over State (_ { msg = Nothing } ) st
      }

pair :: forall eff x y. Command (x -> y) -> Run eff x -> Aff eff y
pair (PutMsg msg next) (Run i) = next <$> (i.putMsg msg)
pair (Reset next) (Run i) = next <$> i.reset

runInterp :: forall eff. Store State -> Free Command (State -> State) -> State -> Aff eff State
runInterp store cmds state = exploreM pair cmds (mkInterp state)

testSuite :: forall e. TestSuite (redox :: RedoxStore (create :: CreateRedox) | e)
testSuite =
  suite "server side rendering"
    let
      disp
        :: forall e1
         . Store State
        -> Free Command (State -> State)
        -> Eff
            ( redox :: RedoxStore ReadWriteRedox | e1)
            (Fiber ( redox :: RedoxStore ReadWriteRedox | e1) Unit)
      disp store = Redox.dispatch (const $ pure unit) (runInterp store) store

      cls :: ReactClass { msg :: Maybe String }
      cls = createClass (spec unit renderCls)
      renderCls this = do
        { msg } <- getProps this
        let msg_ = fromMaybe "" msg
        pure (div' [ text msg_ ])

      connCls :: ReactClass Unit
      connCls = connect
        (Proxy :: Proxy State)
        (to (un State))
        (\_ { msg } _ -> { msg })
        cls
    in do
      test "connect"
        do
          str <- liftEff do
            store <- mkStore (State { msg: Just "hello" })
            top <- withStore store disp (createClassStateless \_ -> createElement connCls unit [])
            pure $ renderToString (createElement top unit [])
          equal str """
hello
"""

      test "componentWillMount" do
        str <- liftEff do
          store <- mkStore (State { msg: Nothing })
          let

            topSpec = (spec unit renderTop)
              { componentWillMount = componentWillMount
              , componentDidMount = componentDidMount
              }

            renderTop _ = pure $ createElement connCls unit []

            componentWillMount _ = do
              -- is called
              void $ disp store (putMsg "hello")

            componentDidMount _ = do
              -- is not called
              void $ disp store reset

          top <- withStore store disp (createClass topSpec)
          pure $ renderToString (createElement top unit [])
        equal str """
hello
"""