fix keyboard events

fix keyboard events

module Data.DOM.Simple.Events where

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent   = "mousemove"
  show MouseOverEvent   = "mouseover"
  show MouseEnterEvent  = "mouseenter"
  show MouseOutEvent    = "mouseout"
  show MouseLeaveEvent  = "mouseleave"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"   = MouseMoveEvent
  read "mouseover"   = MouseOverEvent
  read "mouseenter"  = MouseEnterEvent
  read "mouseout"    = MouseOutEvent
  read "mouseleave"  = MouseLeaveEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | KeypressEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show KeypressEvent       = "keypress"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"  = KeydownEvent
  read "keypress" = KeypressEvent
  read "keyup"    = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Number -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}

module Data.DOM.Simple.Events where

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent   = "mousemove"
  show MouseOverEvent   = "mouseover"
  show MouseEnterEvent  = "mouseenter"
  show MouseOutEvent    = "mouseout"
  show MouseLeaveEvent  = "mouseleave"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"   = MouseMoveEvent
  read "mouseover"   = MouseOverEvent
  read "mouseenter"  = MouseEnterEvent
  read "mouseout"    = MouseOutEvent
  read "mouseleave"  = MouseLeaveEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | BeforeInputEvent | InputEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show BeforeInputEvent = "beforeinput"
  show InputEvent       = "input"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"     = KeydownEvent
  read "beforeinput" = BeforeInputEvent
  read "input"       = InputEvent
  read "keyup"       = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Number -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}


Fix: Close mobile menu while clicking to logo

to redirect to Dashboard

module Explorer.Update where

import Prelude

import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime)
import Control.SocketIO.Client (Socket, SocketIO, emit, emitData)
import DOM (DOM)
import DOM.Event.Event (target, preventDefault)
import DOM.HTML (window)
import DOM.HTML.HTMLElement (blur, focus)
import DOM.HTML.HTMLInputElement (select)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState)
import DOM.HTML.Window (history)
import DOM.Node.Node (contains)
import DOM.Node.Types (ElementId(..), elementToNode)
import Data.Array (filter, snoc, take, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
import Data.Foreign (toForeign)
import Data.Int (fromString)
import Data.Lens ((^.), over, set)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)
import Explorer.Api.Http (fetchAddressSummary, fetchBlockSummary, fetchBlockTxs, fetchBlocksTotalPages, fetchLatestTxs, fetchPageBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Types (RequestLimit(..), RequestOffset(..), SocketOffset(..), SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (translate)
import Explorer.I18n.Lenses (common, cAddress, cBlock, cCalculator, cEpoch, cSlot, cTitle, cTransaction, notfound, nfTitle) as I18nL
import Explorer.Lenses.State (_PageNumber, addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, dbViewNextBlockPagination, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, gWaypoints, globalViewState, lang, latestBlocks, latestTransactions, loading, route, socket, subscriptions, syncAction, viewStates)
import Explorer.Routes (Route(..), match, toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, headerSearchContainerId, heroSearchContainerId, minPagination, mkSocketSubscriptionItem, mobileMenuSearchContainerId)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.App (AppEffects)
import Explorer.Types.State (PageNumber(..), PageSize(..), Search(..), SocketSubscriptionItem(..), State, WaypointItem(..))
import Explorer.Util.Config (SyncAction(..), syncBySocket)
import Explorer.Util.DOM (addClassToElement, findElementById, removeClassFromElement, scrollTop, nodeToHTMLElement, nodeToHTMLInputElement)
import Explorer.Util.Data (sortTxsByTime', unionTxs)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Blocks (maxBlockRows)
import Explorer.View.CSS (dashBoardBlocksViewId, headerId, moveIn, moveOut) as CSS
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Explorer.View.Dashboard.Transactions (maxTransactionRows)
import Network.RemoteData (RemoteData(..), _Success, isNotAsked, isSuccess, withDefault)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, caAddress, caTxList)
import Pux (EffModel, noEffects, onlyEffects)
import Waypoints (WAYPOINT, destroy, waypoint', up) as WP

update :: forall eff. Action -> State -> EffModel State Action (AppEffects eff)

-- Language

update (SetLanguage lang) state = noEffects $ state { lang = lang }

-- Socket

update (SocketConnected connected') state =
    { state: set (socket <<< connected) connected' state
    , effects:
          [ if connected'
            then pure $ Just SocketReconnectSubscriptions
            else pure Nothing
          ]
    }

update SocketPing state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit socket' $ toEvent CallMe
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) state =
    noEffects $
    set latestBlocks latestBlocksCheck $
    set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages) state
  where
    latestBlocksCheck = if pageIsLastPage
                        then (Success blocks)
                        else (state ^. latestBlocks)
    pageIsLastPage = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                  == PageNumber totalPages

update (SocketBlocksPageUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- Important note:
    -- Don't set `latestBlocks` to (Failure error) here
    -- because we would lost all the previous (valid) data in `latestBlocks`
    -- and in the UI. So just add incoming errors ahead of previous errors.
    over errors (\errors' -> (show error) : errors') state

update (SocketTxsUpdated (Right txs)) state =
    noEffects $
    over latestTransactions
        (\currentTxs -> Success <<<
                            sortTxsByTime' <<<
                            take maxTransactionRows $
                                unionTxs txs $
                                    withDefault [] currentTxs
        )
    state

update (SocketTxsUpdated (Left error)) state = noEffects $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state

update (SocketAddressTxsUpdated (Right txs)) state =
    noEffects $
    if isSuccess addrSummary
    then do
        -- Add latest tx on top to other txs of an address
        -- Note: We have to "over" `addrSummary` and set
        -- `currentAddressSummary` explicitly to update the view
        let addrSummary' = over (_Success <<< _CAddressSummary <<< caTxList)
                              (\txs' -> txs <> txs') addrSummary
        set currentAddressSummary addrSummary' state
    else state
    where
        addrSummary = state ^. currentAddressSummary

update (SocketAddressTxsUpdated (Left error)) state = noEffects $
    over errors (\errors' -> (show error) : errors') state

update SocketCallMe state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit socket' $ toEvent CallMe
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketCallMeString str) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emitData socket' (toEvent CallMeString) str
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketCallMeCTxId id) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emitData socket' (toEvent CallMeTxId) id
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Creates a new socket subscription
update (SocketAddSubscription subItem) state =
    { state:
          over (socket <<< subscriptions) (\subs -> snoc subs subItem) state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ socketSubscribeEvent socket' subItem
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Removes an existing socket subscription
update (SocketRemoveSubscription subItem) state =
    { state:
          over (socket <<< subscriptions) (filter ((/=) subItem)) state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ socketUnsubscribeEvent socket' subItem
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Removes all existing socket subscriptions
update (SocketClearSubscriptions) state =
    { state:
          set (socket <<< subscriptions) [] state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                  traverse_ (liftEff <<< socketUnsubscribeEvent socket')
                      (state ^. socket <<< subscriptions)
              Nothing -> pure unit
          pure Nothing
    ]}

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- first unsubscribe from existing subscriptions
                traverse_ (liftEff <<< socketUnsubscribeEvent socket') currentSubs
                -- then subscribe to them again
                traverse_ (liftEff <<< socketSubscribeEvent socket') currentSubs

              Nothing -> pure unit
          pure Nothing
    ]}

-- Dashboard

update (DashboardExpandBlocks expanded) state = noEffects $
    set (dashboardViewState <<< dbViewBlocksExpanded) expanded state

update (DashboardExpandTransactions expanded) state = noEffects $
    set (dashboardViewState <<< dbViewTxsExpanded) expanded state

update (DashboardPaginateBlocks pageNumber) state =
    { state:
          set (dashboardViewState <<< dbViewNextBlockPagination) pageNumber state
    , effects:
          [ pure <<< Just $ RequestPaginatedBlocks pageNumber (PageSize maxBlockRows)
          ]
    }

update (DashboardEditBlocksPageNumber event editable) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (DashboardInvalidBlocksPageNumber event) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) false state
    , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

update (AddressPaginateTxs value) state = noEffects $
    set (viewStates <<< addressDetail <<< addressTxPagination) value state

update (AddressEditTxsPageNumber event editable) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (AddressInvalidTxsPageNumber event) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- Block

update (BlockPaginateTxs value) state = noEffects $
    set (viewStates <<< blockDetail <<< blockTxPagination) value state

update (BlockEditTxsPageNumber event editable) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (BlockInvalidTxsPageNumber event) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- Blocks

update (BlocksPaginateBlocks value) state = noEffects $
    set (viewStates <<< blocksViewState <<< blsViewPagination) value state

update (BlocksEditBlocksPageNumber event editable) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (BlocksInvalidBlocksPageNumber event) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        case state ^. syncAction of
            -- Don't scroll if we are doing polling
            -- TODO (jk) Remove this workaround if socket-io will be fixed
            SyncByPolling -> [ pure Nothing ]
            SyncBySocket -> [ liftEff scrollTop >>= \_ -> pure Nothing ]
    }

update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure Nothing
        ]
    }

update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure Nothing
        ]
    }

update (FocusElement elem) state =
    { state
    , effects:
        [ liftEff $ focus elem >>= \_ -> pure Nothing
        ]
    }

update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure Nothing
        ]
    }

update (DashboardAddWaypoint elementId) state =
    { state
    , effects:
        [ liftEff waypoint >>= \wp -> pure <<< Just <<< StoreWaypoint $ WaypointItem { wpInstance: wp, wpRoute: Dashboard }
        ]
    }
    where
        elId = ElementId CSS.headerId
        callback = \(direction) ->
            if direction == WP.up
                then do
                    addClassToElement elId CSS.moveOut
                    removeClassFromElement elId CSS.moveIn
                else do
                    addClassToElement elId CSS.moveIn
                    removeClassFromElement elId CSS.moveOut

        waypoint = WP.waypoint' elementId callback 71 -- 71 == height of header

update (StoreWaypoint wp) state = noEffects $
    over (viewStates <<< globalViewState <<< gWaypoints) ((:) wp) state

update ClearWaypoints state =
    { state: set (viewStates <<< globalViewState <<< gWaypoints) [] state
    , effects:
          [ do
                traverse_ (liftEff <<< disposeWaypoint) waypointItems
                pure Nothing
          ]
    }
    where
      waypointItems = state ^. (viewStates <<< globalViewState <<< gWaypoints)

      -- | Disposes any `Waypoint` stored in state
      -- | Use it to reverse any changes which might be added by a Waypoint before,
      -- | e.g. adding of new CSS classes or something else
      disposeWaypoint :: forall e. WaypointItem -> Eff (dom :: DOM, waypoint :: WP.WAYPOINT | e) Unit
      disposeWaypoint (WaypointItem item) = do
          _ <- case _.wpRoute item of
                    Dashboard -> do
                      -- remove all css classes which might be added
                      -- by waypoint's callback
                      let elId = ElementId CSS.headerId
                      _ <- removeClassFromElement elId CSS.moveOut
                      _ <- removeClassFromElement elId CSS.moveIn
                      pure unit
                    -- Add any other effects for any other route if needed here
                    _ -> pure unit
          _ <- WP.destroy $ _.wpInstance item
          pure unit

update (DocumentClicked event) state =
    { state
    , effects:
        [ liftEff $
            -- First check here is to see if a search container has been clicked or not.
            -- We do ignore this check if the mobile menue is openend,
            -- because we don't need to do any effects there
            if (not (state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)))
            then
                do
                -- Check if any children of one of our three search containers has been clicked or not
                  heroSearchContainerClicked <- findElementById heroSearchContainerId >>= elementClicked
                  mobileMenuSearchContainerClicked <- findElementById mobileMenuSearchContainerId >>= elementClicked
                  headerSearchContainerClicked <- findElementById headerSearchContainerId >>= elementClicked
                  -- If any of these children are clicked we know, that the search UI has been set to active (focused)
                  let clicked = heroSearchContainerClicked || mobileMenuSearchContainerClicked || headerSearchContainerClicked
                  pure <<< Just $ GlobalFocusSearchInput clicked
            else
                pure Nothing
        ]
    }
    where
        elementClicked mEl =
            case mEl of
                Just el ->
                    contains (elementToNode el) (target event)
                Nothing ->
                    pure false

-- global state
update (GlobalToggleMobileMenu toggled) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) toggled state

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value $
    over (viewStates <<< globalViewState <<< gViewSelectedSearch)
        (\selectedSearch ->
              -- return to `SearchAddress` in inactive mode, but not in mobile menu
              if value == false &&
                    (not $ state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend))
              then SearchAddress
              else selectedSearch
        )
    state

update (GlobalSearch event) state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchQuery) in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchQuery) emptySearchQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure <<< Just $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              pure <<< Just $ Navigate (toUrl <<< Address $ mkCAddress query) event
          SearchTx ->
              pure <<< Just $ Navigate (toUrl <<< Tx $ mkCTxId query) event
          _ -> pure Nothing  -- TODO (ks) maybe put up a message?
      ]
    }
update (GlobalSearchTime event) state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) emptySearchTimeQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure <<< Just $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                pure <<< Just $ Navigate (toUrl epochSlotUrl) event
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                pure <<< Just $ Navigate (toUrl epochUrl) event

            _ -> pure Nothing -- TODO (ks) maybe put up a message?
      ]
    }

update (GlobalUpdateSelectedSearch search) state =
    noEffects $
        set (viewStates <<< globalViewState <<< gViewSelectedSearch) search
        state

update (GlobalUpdateSearchValue search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchQuery) search state

update (GlobalUpdateSearchEpochValue value) state =
    let slot = snd $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
        epoch = fromString value
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

update (GlobalUpdateSearchSlotValue value) state =
    let slot = fromString value
        epoch = fst $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

-- NoOp

update NoOp state = noEffects state

-- http endpoints

update DashboardRequestBlocksTotalPages state =
    { state:
          set loading true $
          set (dashboardViewState <<< dbViewMaxBlockPagination) Loading
          state
    , effects: [ attempt fetchBlocksTotalPages >>= pure <<< Just <<< DashboardReceiveBlocksTotalPages ]
    }

update (DashboardReceiveBlocksTotalPages (Right totalPages)) state =
    { state:
          set loading false $
          set (dashboardViewState <<< dbViewMaxBlockPagination)
              (Success $ PageNumber totalPages) $
          set (dashboardViewState <<< dbViewBlockPagination)
              (PageNumber totalPages) state
    , effects:
        [ pure <<< Just $ DashboardPaginateBlocks (PageNumber totalPages) ]
    }

update (DashboardReceiveBlocksTotalPages (Left error)) state =
    noEffects $
    set loading false $
    set (dashboardViewState <<< dbViewMaxBlockPagination) (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestPaginatedBlocks pageNumber pageSize) state =
    { state:
          set loading true $
          -- Important note: Don't use `set latestBlocks Loading` here,
          -- we will empty `latestBlocks` in this case !!!
          -- set latestBlocks Loading
          set (dashboardViewState <<< dbViewLoadingBlockPagination) true
          state
    , effects: [ attempt (fetchPageBlocks pageNumber pageSize) >>= pure <<< Just <<< ReceivePaginatedBlocks ]
    }

update (ReceivePaginatedBlocks (Right (Tuple totalPages blocks))) state =
    { state:
          set loading false $
          set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages) $
          set (dashboardViewState <<< dbViewBlockPagination) (PageNumber newPage) $
          set (dashboardViewState <<< dbViewLoadingBlockPagination) false $
          set latestBlocks (Success blocks) state
    , effects:
        if (syncBySocket $ state ^. syncAction)
        then [ pure <<< Just $ SocketAddSubscription subItem ]
        else []
    }
    where
        newPage = state ^. (dashboardViewState <<< dbViewNextBlockPagination <<< _PageNumber)
        subItem = mkSocketSubscriptionItem (SocketSubscription SubBlockLastPage) SocketNoData

update (ReceivePaginatedBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set (dashboardViewState <<< dbViewLoadingBlockPagination) false <<<
    set latestBlocks (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockSummary hash) state =
    { state:
          set loading true $
          set currentBlockSummary Loading
          state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< Just <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Success blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Failure error) $
    over errors (\errors' -> (show error) : errors')
    state

-- Epoch, slot

update (RequestSearchBlocks epoch slot) state =
    { state:
          set loading true $
          set currentBlocksResult Loading
          state
    , effects: [ attempt (searchEpoch epoch slot) >>= pure <<< Just <<< ReceiveSearchBlocks ]
    }
update (ReceiveSearchBlocks (Right blocks)) state =
    noEffects $
    set loading false $
    set currentBlocksResult (Success blocks) state

update (ReceiveSearchBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockTxs hash) state =
    { state:
          set loading true $
          set currentBlockTxs Loading
          state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< Just <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Success txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestLastTxs) state =
    { state:
          set loading true <<<
          set latestTransactions Loading $
          state
    , effects:
        [ attempt (fetchLatestTxs (RequestLimit maxTransactionRows) (RequestOffset 0)) >>=
              pure <<< Just <<< ReceiveLastTxs
        ]
    }

update (ReceiveLastTxs (Right txs)) state =
    { state:
          set loading false $
          over latestTransactions
              (\currentTxs -> Success <<<
                                  sortTxsByTime' <<<
                                  take maxTransactionRows $
                                      unionTxs txs $
                                          withDefault [] currentTxs
              )
          state
    , effects:
        if (syncBySocket $ state ^. syncAction)
        then [ pure <<< Just $ SocketAddSubscription subItem ]
        else []
    }
    where
        subItem = mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData

update (ReceiveLastTxs (Left error)) state = noEffects $
    set loading false $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state:
          set loading true $
          set currentTxSummary Loading
          state
    , effects: [ attempt (fetchTxSummary id) >>= pure <<< Just <<< ReceiveTxSummary ]
    }
update (ReceiveTxSummary (Right tx)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Success tx) state
update (ReceiveTxSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestAddressSummary address) state =
    { state:
          set loading true $
          set currentAddressSummary Loading
          state
    , effects: [ attempt (fetchAddressSummary address) >>= pure <<< Just <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure <<< Just $ GenerateQrCode caAddress'
        ]
        <>  ( if (syncBySocket $ state ^. syncAction)
              then [ pure <<< Just $ SocketAddSubscription subItem ]
              else []
            )
    }
    where
        caAddress' = address ^. (_CAddressSummary <<< caAddress)
        subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) (SocketCAddressData caAddress')

update (ReceiveAddressSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentAddressSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

-- clock
update UpdateClock state = onlyEffects state
    [ do
        Just <<< SetClock <<< extract <$> liftEff nowDateTime
    ]

update (SetClock date) state = noEffects $ state { now = date }

-- Reload pages
-- TODO (jk) Remove it if socket-io is back
update Reload state = update (UpdateView state.route) state

-- routing

update (Navigate url ev) state = onlyEffects state
    [ do
        liftEff do
            preventDefault ev
            h <- history =<< window
            -- TODO (jk) Set document title
            pushState (toForeign {}) (DocumentTitle "") (URL url) h
        pure <<< Just $ UpdateView (match url)
    ]

update (UpdateView r@Dashboard) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang) $
        set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just <<< DashboardAddWaypoint $ ElementId CSS.dashBoardBlocksViewId
        , if isSuccess maxBlockPage
          then pure <<< Just <<< DashboardPaginateBlocks $ state ^. (dashboardViewState <<< dbViewBlockPagination)
          else
              -- Note: Request `total pages `only once.
              -- Check is needed due reloading by http pooling
              if isNotAsked maxBlockPage
              then pure $ Just DashboardRequestBlocksTotalPages
              else pure Nothing
        , pure $ Just RequestLastTxs
        ]
    }
    where
        maxBlockPage = state ^. (dashboardViewState <<< dbViewMaxBlockPagination)

update (UpdateView r@(Tx tx)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestTxSummary tx
        ]
    }

update (UpdateView r@(Address cAddress)) state =
    { state:
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) (PageNumber minPagination) $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestAddressSummary cAddress
        ]
    }

update (UpdateView r@(Epoch epochIndex)) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            (PageNumber minPagination) $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just $ RequestSearchBlocks epochIndex Nothing
        ]
    }

update (UpdateView r@(EpochSlot epochIndex slotIndex)) state =
    let lang' = state ^. lang
        epochTitle = translate (I18nL.common <<< I18nL.cEpoch) lang'
        slotTitle = translate (I18nL.common <<< I18nL.cSlot) lang'
    in
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (epochTitle <> " / " <> slotTitle) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

update (UpdateView r@Calculator) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        ]
    }

update (UpdateView r@(Block hash)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestBlockSummary hash
        , pure <<< Just $ RequestBlockTxs hash
        ]
    }

update (UpdateView r@(Playground)) state =
    { state: set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        ]
    }

update (UpdateView r@(NotFound)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        ]
    }

socketSubscribeEvent :: forall eff . Socket -> SocketSubscriptionItem
    -> Eff (socket :: SocketIO | eff) Unit
socketSubscribeEvent socket (SocketSubscriptionItem item) =
    subscribe socket event subData
    where
        event = toEvent <<< Subscribe <<< unwrap $ _.socketSub item
        subData = _.socketSubData item

        subscribe :: Socket -> String -> SocketSubscriptionData -> Eff (socket :: SocketIO | eff) Unit
        subscribe s e SocketNoData = emit s e
        subscribe s e (SocketOffsetData (SocketOffset o)) = emitData s e o
        subscribe s e (SocketCAddressData (CAddress addr)) = emitData s e addr

socketUnsubscribeEvent :: forall eff . Socket -> SocketSubscriptionItem
    -> Eff (socket :: SocketIO | eff) Unit
socketUnsubscribeEvent socket (SocketSubscriptionItem item)  =
    emit socket event
    where
        event = toEvent <<< Unsubscribe <<< unwrap $ _.socketSub item

module Explorer.Update where

import Prelude

import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime)
import Control.SocketIO.Client (Socket, SocketIO, emit, emitData)
import DOM (DOM)
import DOM.Event.Event (target, preventDefault)
import DOM.HTML (window)
import DOM.HTML.HTMLElement (blur, focus)
import DOM.HTML.HTMLInputElement (select)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState)
import DOM.HTML.Window (history)
import DOM.Node.Node (contains)
import DOM.Node.Types (ElementId(..), elementToNode)
import Data.Array (filter, snoc, take, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
import Data.Foreign (toForeign)
import Data.Int (fromString)
import Data.Lens ((^.), over, set)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)
import Explorer.Api.Http (fetchAddressSummary, fetchBlockSummary, fetchBlockTxs, fetchBlocksTotalPages, fetchLatestTxs, fetchPageBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Types (RequestLimit(..), RequestOffset(..), SocketOffset(..), SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (translate)
import Explorer.I18n.Lenses (common, cAddress, cBlock, cCalculator, cEpoch, cSlot, cTitle, cTransaction, notfound, nfTitle) as I18nL
import Explorer.Lenses.State (_PageNumber, addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, dbViewNextBlockPagination, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, gWaypoints, globalViewState, lang, latestBlocks, latestTransactions, loading, route, socket, subscriptions, syncAction, viewStates)
import Explorer.Routes (Route(..), match, toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, headerSearchContainerId, heroSearchContainerId, minPagination, mkSocketSubscriptionItem, mobileMenuSearchContainerId)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.App (AppEffects)
import Explorer.Types.State (PageNumber(..), PageSize(..), Search(..), SocketSubscriptionItem(..), State, WaypointItem(..))
import Explorer.Util.Config (SyncAction(..), syncBySocket)
import Explorer.Util.DOM (addClassToElement, findElementById, removeClassFromElement, scrollTop, nodeToHTMLElement, nodeToHTMLInputElement)
import Explorer.Util.Data (sortTxsByTime', unionTxs)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Blocks (maxBlockRows)
import Explorer.View.CSS (dashBoardBlocksViewId, headerId, moveIn, moveOut) as CSS
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Explorer.View.Dashboard.Transactions (maxTransactionRows)
import Network.RemoteData (RemoteData(..), _Success, isNotAsked, isSuccess, withDefault)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, caAddress, caTxList)
import Pux (EffModel, noEffects, onlyEffects)
import Waypoints (WAYPOINT, destroy, waypoint', up) as WP

update :: forall eff. Action -> State -> EffModel State Action (AppEffects eff)

-- Language

update (SetLanguage lang) state = noEffects $ state { lang = lang }

-- Socket

update (SocketConnected connected') state =
    { state: set (socket <<< connected) connected' state
    , effects:
          [ if connected'
            then pure $ Just SocketReconnectSubscriptions
            else pure Nothing
          ]
    }

update SocketPing state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit socket' $ toEvent CallMe
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) state =
    noEffects $
    set latestBlocks latestBlocksCheck $
    set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages) state
  where
    latestBlocksCheck = if pageIsLastPage
                        then (Success blocks)
                        else (state ^. latestBlocks)
    pageIsLastPage = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                  == PageNumber totalPages

update (SocketBlocksPageUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- Important note:
    -- Don't set `latestBlocks` to (Failure error) here
    -- because we would lost all the previous (valid) data in `latestBlocks`
    -- and in the UI. So just add incoming errors ahead of previous errors.
    over errors (\errors' -> (show error) : errors') state

update (SocketTxsUpdated (Right txs)) state =
    noEffects $
    over latestTransactions
        (\currentTxs -> Success <<<
                            sortTxsByTime' <<<
                            take maxTransactionRows $
                                unionTxs txs $
                                    withDefault [] currentTxs
        )
    state

update (SocketTxsUpdated (Left error)) state = noEffects $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state

update (SocketAddressTxsUpdated (Right txs)) state =
    noEffects $
    if isSuccess addrSummary
    then do
        -- Add latest tx on top to other txs of an address
        -- Note: We have to "over" `addrSummary` and set
        -- `currentAddressSummary` explicitly to update the view
        let addrSummary' = over (_Success <<< _CAddressSummary <<< caTxList)
                              (\txs' -> txs <> txs') addrSummary
        set currentAddressSummary addrSummary' state
    else state
    where
        addrSummary = state ^. currentAddressSummary

update (SocketAddressTxsUpdated (Left error)) state = noEffects $
    over errors (\errors' -> (show error) : errors') state

update SocketCallMe state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit socket' $ toEvent CallMe
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketCallMeString str) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emitData socket' (toEvent CallMeString) str
              Nothing -> pure unit
          pure Nothing
    ]}

update (SocketCallMeCTxId id) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emitData socket' (toEvent CallMeTxId) id
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Creates a new socket subscription
update (SocketAddSubscription subItem) state =
    { state:
          over (socket <<< subscriptions) (\subs -> snoc subs subItem) state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ socketSubscribeEvent socket' subItem
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Removes an existing socket subscription
update (SocketRemoveSubscription subItem) state =
    { state:
          over (socket <<< subscriptions) (filter ((/=) subItem)) state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ socketUnsubscribeEvent socket' subItem
              Nothing -> pure unit
          pure Nothing
    ]}

-- | Removes all existing socket subscriptions
update (SocketClearSubscriptions) state =
    { state:
          set (socket <<< subscriptions) [] state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                  traverse_ (liftEff <<< socketUnsubscribeEvent socket')
                      (state ^. socket <<< subscriptions)
              Nothing -> pure unit
          pure Nothing
    ]}

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- first unsubscribe from existing subscriptions
                traverse_ (liftEff <<< socketUnsubscribeEvent socket') currentSubs
                -- then subscribe to them again
                traverse_ (liftEff <<< socketSubscribeEvent socket') currentSubs

              Nothing -> pure unit
          pure Nothing
    ]}

-- Dashboard

update (DashboardExpandBlocks expanded) state = noEffects $
    set (dashboardViewState <<< dbViewBlocksExpanded) expanded state

update (DashboardExpandTransactions expanded) state = noEffects $
    set (dashboardViewState <<< dbViewTxsExpanded) expanded state

update (DashboardPaginateBlocks pageNumber) state =
    { state:
          set (dashboardViewState <<< dbViewNextBlockPagination) pageNumber state
    , effects:
          [ pure <<< Just $ RequestPaginatedBlocks pageNumber (PageSize maxBlockRows)
          ]
    }

update (DashboardEditBlocksPageNumber event editable) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (DashboardInvalidBlocksPageNumber event) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) false state
    , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

update (AddressPaginateTxs value) state = noEffects $
    set (viewStates <<< addressDetail <<< addressTxPagination) value state

update (AddressEditTxsPageNumber event editable) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (AddressInvalidTxsPageNumber event) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- Block

update (BlockPaginateTxs value) state = noEffects $
    set (viewStates <<< blockDetail <<< blockTxPagination) value state

update (BlockEditTxsPageNumber event editable) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (BlockInvalidTxsPageNumber event) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- Blocks

update (BlocksPaginateBlocks value) state = noEffects $
    set (viewStates <<< blocksViewState <<< blsViewPagination) value state

update (BlocksEditBlocksPageNumber event editable) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) editable state
    , effects:
          [ if editable
            then pure <<< Just $ SelectInputText $ nodeToHTMLInputElement (target event)
            else pure Nothing
          ]
    }

update (BlocksInvalidBlocksPageNumber event) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) false state
      , effects:
          [ pure <<< Just $ BlurElement $ nodeToHTMLElement (target event)
          ]
    }

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        case state ^. syncAction of
            -- Don't scroll if we are doing polling
            -- TODO (jk) Remove this workaround if socket-io will be fixed
            SyncByPolling -> [ pure Nothing ]
            SyncBySocket -> [ liftEff scrollTop >>= \_ -> pure Nothing ]
    }

update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure Nothing
        ]
    }

update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure Nothing
        ]
    }

update (FocusElement elem) state =
    { state
    , effects:
        [ liftEff $ focus elem >>= \_ -> pure Nothing
        ]
    }

update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure Nothing
        ]
    }

update (DashboardAddWaypoint elementId) state =
    { state
    , effects:
        [ liftEff waypoint >>= \wp -> pure <<< Just <<< StoreWaypoint $ WaypointItem { wpInstance: wp, wpRoute: Dashboard }
        ]
    }
    where
        elId = ElementId CSS.headerId
        callback = \(direction) ->
            if direction == WP.up
                then do
                    addClassToElement elId CSS.moveOut
                    removeClassFromElement elId CSS.moveIn
                else do
                    addClassToElement elId CSS.moveIn
                    removeClassFromElement elId CSS.moveOut

        waypoint = WP.waypoint' elementId callback 71 -- 71 == height of header

update (StoreWaypoint wp) state = noEffects $
    over (viewStates <<< globalViewState <<< gWaypoints) ((:) wp) state

update ClearWaypoints state =
    { state: set (viewStates <<< globalViewState <<< gWaypoints) [] state
    , effects:
          [ do
                traverse_ (liftEff <<< disposeWaypoint) waypointItems
                pure Nothing
          ]
    }
    where
      waypointItems = state ^. (viewStates <<< globalViewState <<< gWaypoints)

      -- | Disposes any `Waypoint` stored in state
      -- | Use it to reverse any changes which might be added by a Waypoint before,
      -- | e.g. adding of new CSS classes or something else
      disposeWaypoint :: forall e. WaypointItem -> Eff (dom :: DOM, waypoint :: WP.WAYPOINT | e) Unit
      disposeWaypoint (WaypointItem item) = do
          _ <- case _.wpRoute item of
                    Dashboard -> do
                      -- remove all css classes which might be added
                      -- by waypoint's callback
                      let elId = ElementId CSS.headerId
                      _ <- removeClassFromElement elId CSS.moveOut
                      _ <- removeClassFromElement elId CSS.moveIn
                      pure unit
                    -- Add any other effects for any other route if needed here
                    _ -> pure unit
          _ <- WP.destroy $ _.wpInstance item
          pure unit

update (DocumentClicked event) state =
    { state
    , effects:
        [ liftEff $
            -- First check here is to see if a search container has been clicked or not.
            -- We do ignore this check if the mobile menue is openend,
            -- because we don't need to do any effects there
            if (not (state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)))
            then
                do
                -- Check if any children of one of our three search containers has been clicked or not
                  heroSearchContainerClicked <- findElementById heroSearchContainerId >>= elementClicked
                  mobileMenuSearchContainerClicked <- findElementById mobileMenuSearchContainerId >>= elementClicked
                  headerSearchContainerClicked <- findElementById headerSearchContainerId >>= elementClicked
                  -- If any of these children are clicked we know, that the search UI has been set to active (focused)
                  let clicked = heroSearchContainerClicked || mobileMenuSearchContainerClicked || headerSearchContainerClicked
                  pure <<< Just $ GlobalFocusSearchInput clicked
            else
                pure Nothing
        ]
    }
    where
        elementClicked mEl =
            case mEl of
                Just el ->
                    contains (elementToNode el) (target event)
                Nothing ->
                    pure false

-- global state
update (GlobalToggleMobileMenu toggled) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) toggled state

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value $
    over (viewStates <<< globalViewState <<< gViewSelectedSearch)
        (\selectedSearch ->
              -- return to `SearchAddress` in inactive mode, but not in mobile menu
              if value == false &&
                    (not $ state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend))
              then SearchAddress
              else selectedSearch
        )
    state

update (GlobalSearch event) state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchQuery) in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchQuery) emptySearchQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure <<< Just $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              pure <<< Just $ Navigate (toUrl <<< Address $ mkCAddress query) event
          SearchTx ->
              pure <<< Just $ Navigate (toUrl <<< Tx $ mkCTxId query) event
          _ -> pure Nothing  -- TODO (ks) maybe put up a message?
      ]
    }
update (GlobalSearchTime event) state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) emptySearchTimeQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure <<< Just $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                pure <<< Just $ Navigate (toUrl epochSlotUrl) event
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                pure <<< Just $ Navigate (toUrl epochUrl) event

            _ -> pure Nothing -- TODO (ks) maybe put up a message?
      ]
    }

update (GlobalUpdateSelectedSearch search) state =
    noEffects $
        set (viewStates <<< globalViewState <<< gViewSelectedSearch) search
        state

update (GlobalUpdateSearchValue search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchQuery) search state

update (GlobalUpdateSearchEpochValue value) state =
    let slot = snd $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
        epoch = fromString value
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

update (GlobalUpdateSearchSlotValue value) state =
    let slot = fromString value
        epoch = fst $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

-- NoOp

update NoOp state = noEffects state

-- http endpoints

update DashboardRequestBlocksTotalPages state =
    { state:
          set loading true $
          set (dashboardViewState <<< dbViewMaxBlockPagination) Loading
          state
    , effects: [ attempt fetchBlocksTotalPages >>= pure <<< Just <<< DashboardReceiveBlocksTotalPages ]
    }

update (DashboardReceiveBlocksTotalPages (Right totalPages)) state =
    { state:
          set loading false $
          set (dashboardViewState <<< dbViewMaxBlockPagination)
              (Success $ PageNumber totalPages) $
          set (dashboardViewState <<< dbViewBlockPagination)
              (PageNumber totalPages) state
    , effects:
        [ pure <<< Just $ DashboardPaginateBlocks (PageNumber totalPages) ]
    }

update (DashboardReceiveBlocksTotalPages (Left error)) state =
    noEffects $
    set loading false $
    set (dashboardViewState <<< dbViewMaxBlockPagination) (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestPaginatedBlocks pageNumber pageSize) state =
    { state:
          set loading true $
          -- Important note: Don't use `set latestBlocks Loading` here,
          -- we will empty `latestBlocks` in this case !!!
          -- set latestBlocks Loading
          set (dashboardViewState <<< dbViewLoadingBlockPagination) true
          state
    , effects: [ attempt (fetchPageBlocks pageNumber pageSize) >>= pure <<< Just <<< ReceivePaginatedBlocks ]
    }

update (ReceivePaginatedBlocks (Right (Tuple totalPages blocks))) state =
    { state:
          set loading false $
          set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages) $
          set (dashboardViewState <<< dbViewBlockPagination) (PageNumber newPage) $
          set (dashboardViewState <<< dbViewLoadingBlockPagination) false $
          set latestBlocks (Success blocks) state
    , effects:
        if (syncBySocket $ state ^. syncAction)
        then [ pure <<< Just $ SocketAddSubscription subItem ]
        else []
    }
    where
        newPage = state ^. (dashboardViewState <<< dbViewNextBlockPagination <<< _PageNumber)
        subItem = mkSocketSubscriptionItem (SocketSubscription SubBlockLastPage) SocketNoData

update (ReceivePaginatedBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set (dashboardViewState <<< dbViewLoadingBlockPagination) false <<<
    set latestBlocks (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockSummary hash) state =
    { state:
          set loading true $
          set currentBlockSummary Loading
          state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< Just <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Success blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Failure error) $
    over errors (\errors' -> (show error) : errors')
    state

-- Epoch, slot

update (RequestSearchBlocks epoch slot) state =
    { state:
          set loading true $
          set currentBlocksResult Loading
          state
    , effects: [ attempt (searchEpoch epoch slot) >>= pure <<< Just <<< ReceiveSearchBlocks ]
    }
update (ReceiveSearchBlocks (Right blocks)) state =
    noEffects $
    set loading false $
    set currentBlocksResult (Success blocks) state

update (ReceiveSearchBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockTxs hash) state =
    { state:
          set loading true $
          set currentBlockTxs Loading
          state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< Just <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Success txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestLastTxs) state =
    { state:
          set loading true <<<
          set latestTransactions Loading $
          state
    , effects:
        [ attempt (fetchLatestTxs (RequestLimit maxTransactionRows) (RequestOffset 0)) >>=
              pure <<< Just <<< ReceiveLastTxs
        ]
    }

update (ReceiveLastTxs (Right txs)) state =
    { state:
          set loading false $
          over latestTransactions
              (\currentTxs -> Success <<<
                                  sortTxsByTime' <<<
                                  take maxTransactionRows $
                                      unionTxs txs $
                                          withDefault [] currentTxs
              )
          state
    , effects:
        if (syncBySocket $ state ^. syncAction)
        then [ pure <<< Just $ SocketAddSubscription subItem ]
        else []
    }
    where
        subItem = mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData

update (ReceiveLastTxs (Left error)) state = noEffects $
    set loading false $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state:
          set loading true $
          set currentTxSummary Loading
          state
    , effects: [ attempt (fetchTxSummary id) >>= pure <<< Just <<< ReceiveTxSummary ]
    }
update (ReceiveTxSummary (Right tx)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Success tx) state
update (ReceiveTxSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestAddressSummary address) state =
    { state:
          set loading true $
          set currentAddressSummary Loading
          state
    , effects: [ attempt (fetchAddressSummary address) >>= pure <<< Just <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure <<< Just $ GenerateQrCode caAddress'
        ]
        <>  ( if (syncBySocket $ state ^. syncAction)
              then [ pure <<< Just $ SocketAddSubscription subItem ]
              else []
            )
    }
    where
        caAddress' = address ^. (_CAddressSummary <<< caAddress)
        subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) (SocketCAddressData caAddress')

update (ReceiveAddressSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentAddressSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

-- clock
update UpdateClock state = onlyEffects state
    [ do
        Just <<< SetClock <<< extract <$> liftEff nowDateTime
    ]

update (SetClock date) state = noEffects $ state { now = date }

-- Reload pages
-- TODO (jk) Remove it if socket-io is back
update Reload state = update (UpdateView state.route) state

-- routing

update (Navigate url ev) state = onlyEffects state
    [ do
        liftEff do
            preventDefault ev
            h <- history =<< window
            -- TODO (jk) Set document title
            pushState (toForeign {}) (DocumentTitle "") (URL url) h
        pure <<< Just $ UpdateView (match url)
    ]

update (UpdateView r@Dashboard) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just <<< DashboardAddWaypoint $ ElementId CSS.dashBoardBlocksViewId
        , if isSuccess maxBlockPage
          then pure <<< Just <<< DashboardPaginateBlocks $ state ^. (dashboardViewState <<< dbViewBlockPagination)
          else
              -- Note: Request `total pages `only once.
              -- Check is needed due reloading by http pooling
              if isNotAsked maxBlockPage
              then pure $ Just DashboardRequestBlocksTotalPages
              else pure Nothing
        , pure $ Just RequestLastTxs
        ]
    }
    where
        maxBlockPage = state ^. (dashboardViewState <<< dbViewMaxBlockPagination)

update (UpdateView r@(Tx tx)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestTxSummary tx
        ]
    }

update (UpdateView r@(Address cAddress)) state =
    { state:
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) (PageNumber minPagination) $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestAddressSummary cAddress
        ]
    }

update (UpdateView r@(Epoch epochIndex)) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            (PageNumber minPagination) $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just $ RequestSearchBlocks epochIndex Nothing
        ]
    }

update (UpdateView r@(EpochSlot epochIndex slotIndex)) state =
    let lang' = state ^. lang
        epochTitle = translate (I18nL.common <<< I18nL.cEpoch) lang'
        slotTitle = translate (I18nL.common <<< I18nL.cSlot) lang'
    in
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (epochTitle <> " / " <> slotTitle) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure <<< Just $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

update (UpdateView r@Calculator) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        ]
    }

update (UpdateView r@(Block hash)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        , pure <<< Just $ RequestBlockSummary hash
        , pure <<< Just $ RequestBlockTxs hash
        ]
    }

update (UpdateView r@(Playground)) state =
    { state: set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        ]
    }

update (UpdateView r@(NotFound)) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang) $
        set route r state
    , effects:
        [ pure $ Just ScrollTop
        , pure $ Just ClearWaypoints
        , pure $ Just SocketClearSubscriptions
        ]
    }

socketSubscribeEvent :: forall eff . Socket -> SocketSubscriptionItem
    -> Eff (socket :: SocketIO | eff) Unit
socketSubscribeEvent socket (SocketSubscriptionItem item) =
    subscribe socket event subData
    where
        event = toEvent <<< Subscribe <<< unwrap $ _.socketSub item
        subData = _.socketSubData item

        subscribe :: Socket -> String -> SocketSubscriptionData -> Eff (socket :: SocketIO | eff) Unit
        subscribe s e SocketNoData = emit s e
        subscribe s e (SocketOffsetData (SocketOffset o)) = emitData s e o
        subscribe s e (SocketCAddressData (CAddress addr)) = emitData s e addr

socketUnsubscribeEvent :: forall eff . Socket -> SocketSubscriptionItem
    -> Eff (socket :: SocketIO | eff) Unit
socketUnsubscribeEvent socket (SocketSubscriptionItem item)  =
    emit socket event
    where
        event = toEvent <<< Unsubscribe <<< unwrap $ _.socketSub item


bug fix

bug fix

module Sawmill.DOM
    ( module Sawmill.DOM.Eff
    , module Sawmill.DOM.Types
    , module Sawmill.DOM.Element
    , module Sawmill.DOM.Event
    , module Sawmill.DOM.Document
    ) where

import Sawmill.DOM.Eff (DOM)
import Sawmill.DOM.Types (Element, Event)
import Sawmill.DOM.Element (addEventListener, removeEventListener, dispatchEvent, childElements, parentElement, appendChild
    , hasChildElements, insertBefore, removeChild, replaceChild, className, setClassName, id, setId, innerHTML, setInnerHTML
    , tagName, getAttribute, setAttribute, hasAttribute, removeAttribtute, getElementsByClassName, getElementsByTagName
    , querySelector, querySelectorAll)
import Sawmill.DOM.Event (bubbles, cancelable, currentTarget, defaultPrevented, eventPhase, target, timeStamp, eventType,
    createEvent, isTrusted, preventDefault, stopPropagation)
import Sawmill.DOM.Document (body, docAddEventListener, docRemoveEventListener, docDispatchEvent)

module Sawmill.DOM
    ( module Sawmill.DOM.Eff
    , module Sawmill.DOM.Types
    , module Sawmill.DOM.Element
    , module Sawmill.DOM.Event
    ) where

import Sawmill.DOM.Eff (DOM)
import Sawmill.DOM.Types (Element, Event)
import Sawmill.DOM.Element (addEventListener, removeEventListener, dispatchEvent, childElements, parentElement, appendChild
    , hasChildElements, insertBefore, removeChild, replaceChild, className, setClassName, id, setId, innerHTML, setInnerHTML
    , tagName, getAttribute, setAttribute, hasAttribute, removeAttribtute, getElementsByClassName, getElementsByTagName
    , querySelector, querySelectorAll)
import Sawmill.DOM.Event (bubbles, cancelable, currentTarget, defaultPrevented, eventPhase, target, timeStamp, eventType,
    createEvent, isTrusted, preventDefault, stopPropagation)


maybe figured out view update system

maybe figured out view update system

module Genetics.Browser.UI.View where

import Prelude

import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Variant (Variant)
import Effect (Effect)
import Effect.Aff (Milliseconds, launchAff_)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(..), normalizeView, scalePairBy, translatePairBy)

foreign import onTimeout
  :: Milliseconds
  -> Effect Unit
  -> Effect { run    :: Effect Unit
            , cancel :: Effect Unit }

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView identity

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

data Animation =
    Scrolling Number
  | Zooming   (Pair Number)
  | Jump

-- | A `ViewAnimation` describes either an animation that can be applied
-- | to achieve the *visual* effect required to stay in sync with the
-- | current change in view, or a final `CoordSysView` to apply to
-- | relevant tracks when the change in view is finished.
type ViewAnimation = Either Animation CoordSysView

animateDelta' :: ∀ a a' b.
                 Monoid a'
              => (a' -> a -> { velocity :: a'
                             , position :: a
                             , output :: b })
              -> (b -> Effect Unit)
              -> { position :: a
                 , velocity :: a' }
              -> Milliseconds
              -> Effect (a' -> Effect Unit)
animateDelta' update cb initial timeout = do
  velRef <- Ref.new initial.velocity
  posRef <- Ref.new initial.position

  control <- onTimeout timeout do
    vel <- Ref.read velRef
    pos <- Ref.read posRef
    let step = update vel pos
    Ref.write step.velocity velRef
    Ref.write step.position posRef

    cb step.output

  pure \cmd -> do
    Ref.modify_ (_ <> cmd) velRef
    control.run

uiViewUpdate' :: ∀ c r.
                CoordSys c BigInt
             -> Milliseconds
             -> CoordSysView
             -> (CoordSysView -> Effect Unit)
             -> Effect (UpdateView -> Effect Unit)
uiViewUpdate' cs timeout view cb = do
  let done (Left x)  = cb x
      done (Right a) = log "animating"

  animateDelta' (viewUpdate' cs) done { position: view, velocity: mempty } timeout

viewUpdate' :: CoordSys _ BigInt
            -> UpdateView
            -> CoordSysView
            -> { velocity :: UpdateView
               , position :: CoordSysView
               , output   :: Either CoordSysView Animation }
viewUpdate' cs uv curView =
  let updatePosition vD = normalizeView cs (BigInt.fromInt 200000)
                          <<< updateViewFold vD
  in case uv of
       sv@(ScrollView x) ->
         let x' = x * 0.5
             output =  if x' < 0.001 then Left curView
                                     else Right $ Scrolling x
             velocity = ScrollView x'
             position = updatePosition sv curView
         in { velocity, position, output }

       zv@(ZoomView   z) ->
         let z' = z * 0.5
             output =  if z' < 0.001 then Left curView
                                     else Right $ Zooming (Pair 0.25 0.75)
             velocity = ZoomView z'
             position = updatePosition zv curView
         in { velocity, position, output }

       ModView f ->
         let position = wrap $ f $ unwrap curView
         in { velocity: ModView identity
            , position
            , output: Left position }

module Genetics.Browser.UI.View where

import Prelude

import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filterMap)
import Data.Foldable (foldMap, length, sum)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(..))
import Data.Traversable (for_, traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant, case_, inj)
import Data.Variant as V
import Effect (Effect)
import Effect.Aff (Aff, Fiber, Milliseconds(..), delay, forkAff, killFiber, launchAff, launchAff_, throwError)
import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as AVar
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Effect.Exception (error, throw)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Foreign (Foreign, MultipleErrors, renderForeignError)
import Genetics.Browser (HexColor(..), LegendConfig, Peak, VScale, pixelSegments)
import Genetics.Browser.Bed (getGenes)
import Genetics.Browser.Canvas (BrowserContainer, TrackContainer, _Container, addTrack, browserContainer, dragScroll, getDimensions, getTrack, setElementStyle, setTrackContainerSize, trackClickHandler, trackContainer, wheelZoom, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(..), _Segments, _TotalSize, coordSys, normalizeView, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, AnnotationsConfig, SNP, SNPConfig, addChrLayers, addGWASLayers, addGeneLayers, annotationsForScale, filterSig, getAnnotations, getSNPs, showAnnotationField)
import Genetics.Browser.Layer (Component(Center), TrackPadding, trackSlots)
import Genetics.Browser.Track (class TrackRecord, makeContainers, makeTrack)
import Genetics.Browser.Types (ChrId(ChrId), _NegLog10, _prec)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Point)
import Math (pow)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Prim.RowList (class RowToList)
import Record (insert)
import Record as Record
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)
import Web.DOM.Document (createElement, documentElement) as DOM
import Web.DOM.Document (toParentNode)
import Web.DOM.Element (setId)
import Web.DOM.Element as Element
import Web.DOM.Node (appendChild)
import Web.DOM.ParentNode (querySelector) as DOM
import Web.HTML (window) as DOM
import Web.HTML.HTMLDocument (toDocument) as DOM
import Web.HTML.Window (document) as DOM
import Web.UIEvent.KeyboardEvent (KeyboardEvent)
import Web.UIEvent.KeyboardEvent (key) as DOM

foreign import onTimeout
  :: Milliseconds
  -> Effect Unit
  -> Effect { run    :: Effect Unit
            , cancel :: Effect Unit }

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView identity

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

_global      = SProxy :: SProxy "global"
_pixels      = SProxy :: SProxy "pixels"
_viewLengths = SProxy :: SProxy "viewLengths"

-- | A `Translation` describes a translation of a CoordSysView.
-- | `global` defines a translation in global coordinates (summed Bps, roughly);
-- | `pixels` a translation in pixels to the right, depending on the browser canvas width;
-- | `viewLengths` one in terms of the size of the current view, 1.0 == move one view length to the right.

type Translation =
  Variant ( global      :: BigInt
          , pixels      :: Number
          , viewLengths :: Number )

type Around = { around :: Number, viewLengths :: Number }
type ViewRange = Pair Number

_around = SProxy :: SProxy "around"
_viewRange = SProxy :: SProxy "viewRange"

-- | A `Scale` describes a rescaling, or zooming, of a CoordSysView.
-- | `viewLengths` is a scaling action centered at the middle of the
-- | view, such that the new view is set to `viewLengths` times the
-- | old view; `around` is like `viewLengths`, except centered at
-- | another point ({around: 0.5, viewLengths} == viewLengths);
-- | `viewRange` describes the edges of the new CoordSysView in terms
-- | of the old; a `viewRange` with (Pair 0.45 0.55) zooms in at the
-- | middle 10% of the view.
type Scale =
  Variant ( viewLengths :: Number
          , around      :: Around
          , viewRange   :: ViewRange )

data ViewChange =
    TranslateView Translation
  | ScaleView Scale
  | SetView CoordSysView

data Animation =
    Scrolling Number
  | Zooming   ViewRange
  | Jump

type Animator a =
     CoordSysView
  -> a
  -> Maybe { animation :: Animation
           , end       :: CoordSysView }

translateView :: (CoordSysView -> CoordSysView)
              -> Animator Translation
translateView clamp = V.case_

-- | A `ViewAnimation` describes either an animation that can be applied
-- | to achieve the *visual* effect required to stay in sync with the
-- | current change in view, or a final `CoordSysView` to apply to
-- | relevant tracks when the change in view is finished.
type ViewAnimation = Either Animation CoordSysView

animateDelta :: ∀ a a'.
                Monoid a'
             => (a' -> a -> a)
             -> (a -> Effect Unit)
             -> { current  :: Ref a
                , velocity :: Ref a'
                }
             -> Milliseconds
             -> Effect (a' -> Effect Unit)
animateDelta update done refs timeout = do

  comms <- onTimeout timeout do
    vD <- Ref.read refs.velocity
    Ref.write mempty refs.velocity
    launchAff_ $ liftEffect do
      Ref.modify (update vD) refs.current >>= done

  pure \cmd -> do
    Ref.modify_ (_ <> cmd) refs.velocity
    comms.run

type ViewControlOptions =
  { maxScrollTime :: Milliseconds
  , maxZoomTime :: Milliseconds }

defaultViewControlOptions =
  { maxScrollTime: wrap 200.0
  , maxZoomTime:   wrap 400.0 }

type ViewUpdateState =
  { start :: CoordSysView
  , end   :: CoordSysView
  , t     :: Number
  , totalAnimation :: Animation }

foldViewChange :: (CoordSysView -> CoordSysView)
               -> CoordSysView
               -> ViewChange
               -> ViewUpdateState
foldViewChange clamp' curView =
  let viewUpdate end anim = { start: curview, end, t: 0.0, totalAnimation: anim }
  in case _ of
       TranslateView t -> viewUpdate ?hm (Scrolling ?hm2)

       ScaleView     s -> viewUpdate ?hm (Zooming ?hm2)

       SetView     csv -> viewUpdate csv Jump

viewControl :: ∀ c.
               ViewControlOptions
            -> CoordSys c BigInt
            -> Maybe CoordSysView
            -> Milliseconds
            -> Effect { addListener :: (ViewAnimation -> Effect Unit) -> Effect Unit
                      , updateView  :: ViewChange -> Effect Unit }
viewControl opts cSys initView timeout = do

  let normView = normalizeView cSys (BigInt.fromInt 200000)

  currentView   <- Ref.new initView
  targetView    <- Ref.new initView

  currentAction <- Ref.new (Nothing :: Maybe ViewUpdateState)

  -- let updateView = case _ of

  pure $ unsafeCoerce unit

uiViewUpdate :: ∀ c r.
                CoordSys c BigInt
             -> Milliseconds
             -> Ref CoordSysView
             -> Effect Unit
             -> Effect (UpdateView -> Effect Unit)
uiViewUpdate cs timeout view cb = do
  let update vD = normalizeView cs (BigInt.fromInt 200000)
                 <<< updateViewFold vD
      done _ = cb

  velocity <- Ref.new mempty
  animateDelta update done { current: view, velocity } timeout