[CSE-131] Fix calculation to update of blocks

module Explorer.Update where

import Prelude
import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime, NOW)
import Control.SocketIO.Client (SocketIO, emit, emit')
import DOM (DOM)
import DOM.HTML.HTMLElement (blur)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, drop, length, take, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
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, fetchLatestBlocks, fetchLatestTxs, fetchTotalBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Types (RequestLimit(..), RequestOffset(..), SocketSubscription(..), SocketSubscriptionAction(..))
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 (addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewLoadingBlockPagination, dbViewNextBlockPagination, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, lang, latestBlocks, latestTransactions, loading, pullLatestBlocks, pullLatestTxs, route, socket, subscriptions, syncAction, totalBlocks, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), State)
import Explorer.Util.Config (SyncAction(..), syncByPolling, syncBySocket)
import Explorer.Util.DOM (scrollTop, targetToHTMLElement, targetToHTMLInputElement)
import Explorer.Util.Data (sortBlocksByEpochSlot', sortTxsByTime', unionBlocks, unionTxs)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Blocks (maxBlockRows)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Explorer.View.Dashboard.Transactions (maxTransactionRows)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), isNotAsked, isSuccess, withDefault)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, caAddress)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.Router (navigateTo) as P

update :: forall eff. Action -> State ->
    EffModel State Action
    (dom :: DOM
    , ajax :: AJAX
    , socket :: SocketIO
    , now :: NOW
    -- , console :: CONSOLE
    | 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 SocketReconnectSubscriptions
            else pure NoOp
          ]
    }

update (SocketBlocksUpdated (Right blocks)) state =
    noEffects $
    set latestBlocks (Success newBlocks) $
    set totalBlocks (Success newTotalBlocks) state
    where
        prevBlocks = withDefault [] $ state ^. latestBlocks
        numberOfBlocksToCompare = 50
        prevBlocksToCompare = take numberOfBlocksToCompare prevBlocks
        prevBlocksRest = drop numberOfBlocksToCompare prevBlocks
        blocksToAdd = sortBlocksByEpochSlot' $ unionBlocks blocks prevBlocksToCompare
        newBlocks = blocksToAdd <> prevBlocksRest
        previousTotalBlocks = withDefault 0 $ state ^. totalBlocks
        newTotalBlocks = (length newBlocks) - (length prevBlocks) + previousTotalBlocks

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

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

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

update (SocketUpdateSubscriptions nextSubs subAction ) state =
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                case subAction of
                    UnsubscribePrevSubscriptions -> do
                        unsubPrevSubscriptions socket'
                        subNextSubscriptions socket'
                    KeepPrevSubscriptions ->
                        subNextSubscriptions socket'
              Nothing -> pure unit
          pure NoOp
    ]}
        where
            currentSubs = state ^. socket <<< subscriptions
            diffNextFromCurrentSubs = difference currentSubs nextSubs
            unsubPrevSubscriptions socket'' =
                traverse_ (liftEff <<< emit' socket'' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
            diffCurrentFromNextSubs = difference nextSubs currentSubs
            subNextSubscriptions socket'' =
                traverse_ (liftEff <<< emit' socket'' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) currentSubs
              Nothing -> pure unit
          pure NoOp
    ]}

-- Dashboard

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

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

update (DashboardPaginateBlocks newPage) state =
    { state:
          if doRequest
          then set (dashboardViewState <<< dbViewNextBlockPagination) newPage state
          else set (dashboardViewState <<< dbViewBlockPagination) newPage state
    , effects:
          if doRequest
          then [ pure $ RequestPaginatedBlocks (RequestLimit limit) (RequestOffset offset) ]
          else []
    }
    where
        doRequest = doPaginateBlocksRequest state newPage maxBlockRows
        buffer = maxBlockRows
        limit = limitPaginateBlocksRequest state newPage maxBlockRows buffer
        offset = offsetPaginateBlocksRequest state

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

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

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

-- Address

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

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

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

-- Block

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

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

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

-- Blocks

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

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

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

-- 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 NoOp ]
            SyncBySocket -> [ liftEff scrollTop >>= \_ -> pure NoOp ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure NoOp
        ]
    }
update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure NoOp
        ]
    }
update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure NoOp
        ]
    }

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

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value state

update GlobalSearch 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 $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Address $ mkCAddress query) *> pure NoOp
          SearchTx ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Tx $ mkCTxId query) *> pure NoOp
          _ -> pure NoOp  -- TODO (ks) maybe put up a message?
      ]
    }
update GlobalSearchTime 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 $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochSlotUrl) *> pure NoOp
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochUrl) *> pure NoOp

            _ -> pure NoOp -- 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 RequestTotalBlocks state =
    { state:
          set totalBlocks Loading state
    , effects:
          [ attempt fetchTotalBlocks >>= pure <<< ReceiveTotalBlocks
          ]
    }

update (ReceiveTotalBlocks (Right total)) state =
    { state:
          set totalBlocks (Success total) state
    , effects:
        -- request `latestBlocks` if needed only
        if isNotAsked $ state ^. latestBlocks
        then [ pure RequestInitialBlocks ]
        else []
    }

update (ReceiveTotalBlocks (Left error)) state =
    noEffects $
    set totalBlocks (Failure error)
    $ over errors (\errors' -> (show error) : errors') state

update RequestInitialBlocks state =
    { state:
          set loading true $
          set latestBlocks Loading
          state
    , effects:
        [ attempt (fetchLatestBlocks (RequestLimit maxBlockRows) (RequestOffset 0)) >>=
            pure <<< ReceiveInitialBlocks
        ]
    }

update (ReceiveInitialBlocks (Right blocks)) state =
    { state:
          set loading false $
          -- add blocks
          set latestBlocks (Success $ sortBlocksByEpochSlot' blocks) $
          set pullLatestBlocks (syncByPolling $ state ^. syncAction)
          state
    , effects:
          -- add subscription of `SubBlock` if we are on `Dashboard` only
          if (state ^. route) == Dashboard
          then  [ pure $ SocketUpdateSubscriptions
                            [ SocketSubscription SubBlock ]
                            KeepPrevSubscriptions
                ]
          else []
    }

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set latestBlocks (Failure error) $
    set pullLatestBlocks (syncByPolling $ state ^. syncAction) $
    over errors (\errors' -> (show error) : errors') state

-- START #Pulling blocks
-- Pulling blocks is just a workaround to avoid issues w/ socket-io
-- TODO (jk) Remove this workaround if socket-io is back
update RequestBlocksUpdate state =
     { state:
           set loading true $
           -- _Important note_:
           -- Don't do `set latestBlocks Loading` here,
           -- we will empty `latestBlocks` in this case !!!
           state
     , effects: [ attempt (fetchLatestBlocks (RequestLimit 10) (RequestOffset 0)) >>= pure <<< ReceiveBlocksUpdate ]
     }

update (ReceiveBlocksUpdate (Right blocks)) state =
    noEffects $
    set loading false <<<
    set latestBlocks (Success newBlocks) $
    set totalBlocks (Success newTotalBlocks) state
    where
        prevBlocks = withDefault [] $ state ^. latestBlocks
        numberOfBlocksToCompare = 50
        prevBlocksToCompare = take numberOfBlocksToCompare prevBlocks
        prevBlocksRest = drop numberOfBlocksToCompare prevBlocks
        blocksToAdd = sortBlocksByEpochSlot' $ unionBlocks blocks prevBlocksToCompare
        newBlocks = blocksToAdd <> prevBlocksRest
        previousTotalBlocks = withDefault 0 $ state ^. totalBlocks
        newTotalBlocks = (length newBlocks) - (length prevBlocks) + previousTotalBlocks

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

-- END #Pulling blocks

update (RequestPaginatedBlocks limit offset) 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 (fetchLatestBlocks limit offset) >>= pure <<< ReceivePaginatedBlocks ]
    }

update (ReceivePaginatedBlocks (Right blocks)) state =
    noEffects $
    set loading false $
    set (dashboardViewState <<< dbViewBlockPagination) (state ^. (dashboardViewState <<< dbViewNextBlockPagination)) $
    set (dashboardViewState <<< dbViewLoadingBlockPagination) false $
    set latestBlocks (Success newBlocks) state
    where
        previousBlocks = withDefault [] $ state ^. latestBlocks
        newBlocks = sortBlocksByEpochSlot' $ unionBlocks blocks previousBlocks

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 $ state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Just blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    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 <<< 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 $ state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Just txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs Nothing $
    over errors (\errors' -> (show error) : errors') state

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

update (ReceiveInitialTxs (Right txs)) state =
    { state:
          set loading false $
          set pullLatestTxs (syncByPolling $ state ^. syncAction) $
          over latestTransactions
              (\currentTxs -> Success <<<
                                  sortTxsByTime' <<<
                                  take maxTransactionRows $
                                      unionTxs txs $
                                          withDefault [] currentTxs
              )
          state
    , effects:
          -- add subscription of `SubTx` if we are on `Dashboard` only
          if (state ^. route) == Dashboard
          then [ pure $ SocketUpdateSubscriptions
                            [ SocketSubscription SubTx]
                            KeepPrevSubscriptions
                ]
          else []

    }

update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false $
    set pullLatestTxs (syncByPolling $ state ^. syncAction) $
    over errors (\errors' -> (show error) : errors') state

-- START #Pulling txs
-- It is just a workaround to avoid issues w/ socket-io
-- TODO (jk) Remove this workaround if socket-io will be fixed
update RequestTxsUpdate state =
     { state:
           set loading true
           -- _Important note_:
           -- Don't do `set latestTransactions Loading` here,
           -- we will have an empty `latestTransactions` in this case !!!
           state
     , effects:
          [ attempt (fetchLatestTxs (RequestLimit 10) (RequestOffset 0)) >>=
                pure <<< ReceiveTxsUpdate
          ]
     }

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

update (ReceiveTxsUpdate (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 <<< 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 <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure $ GenerateQrCode $ address ^. (_CAddressSummary <<< 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
         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 (UpdateView route) state = routeEffects route (state { route = route })

routeEffects :: forall eff. Route -> State -> EffModel State Action (dom :: DOM
    , ajax :: AJAX | eff)
routeEffects Dashboard state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        ]
        -- get `totalBlocks` only once
        <>  ( if isNotAsked $ state ^. totalBlocks
              then [ pure RequestTotalBlocks ]
              else []
            )
        -- request `latestBlocks` if needed
        <>  ( if  (isSuccess $ state ^. totalBlocks) &&
                  (isNotAsked $ state ^. latestBlocks) &&
                  (not $ state ^. pullLatestBlocks)
              then [ pure RequestInitialBlocks ]
              else []
            )
        -- pull latest blocks if needed
        <>  ( if  (syncByPolling $ state ^. syncAction) &&
                  (state ^. pullLatestBlocks)
              then [ pure RequestBlocksUpdate ]
              else []
            )
        -- request `latestTransactions` if needed
        <>  ( if (isNotAsked $ state ^. latestTransactions) &&
                  (not $ state ^. pullLatestTxs)
              then [ pure RequestInitialTxs ]
              else []
            )
        -- pull latest txs if needed
        <>  ( if  (syncByPolling $ state ^. syncAction) &&
                  (state ^. pullLatestTxs)
              then [ pure RequestTxsUpdate ]
              else []
            )
        -- subscribe to `SubBlock` and `SubTx `if needed
        <>  ( if  (syncBySocket $ state ^. syncAction) &&
                  (isSuccess $ state ^. latestBlocks) &&
                  (isSuccess $ state ^. latestTransactions)
              then [ pure $ SocketUpdateSubscriptions
                              [ SocketSubscription SubBlock
                              , SocketSubscription SubTx
                              ] UnsubscribePrevSubscriptions
                  ]
              else []
            )
    }

routeEffects (Tx tx) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestTxSummary tx
        ]
    }

routeEffects (Address cAddress) state =
    { state:
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestAddressSummary cAddress
        ]
    }

routeEffects (Epoch epochIndex) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex Nothing
        ]
    }

routeEffects (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)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

routeEffects Calculator state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang)
            state
    , effects: [ pure ScrollTop ]
    }

routeEffects (Block hash) state =
    { state:
        set currentBlockSummary Nothing $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

routeEffects Playground state =
    { state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        ]
    }

routeEffects NotFound state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        ]
    }

-- helper functions

-- | Checks if we do need to make a request to get data of next block pagination or not
doPaginateBlocksRequest :: State -> Int -> Int -> Boolean
doPaginateBlocksRequest state nextPage blockRows =
    nextPage > state ^. (dashboardViewState <<< dbViewBlockPagination)
    && lengthBlocks < (nextPage * blockRows)
    && lengthBlocks < (withDefault 0 $ state ^. totalBlocks)
    where
        lengthBlocks = length $ withDefault [] (state ^. latestBlocks)

-- | Determines the `limit` to request pagination of blocks
-- | _Note_: We add some extra "buffer" to get more blocks as needed,
-- | just to avoid to lost any data
limitPaginateBlocksRequest :: State -> Int -> Int -> Int -> Int
limitPaginateBlocksRequest state nextPage blockRows buffer =
    (nextPage * blockRows - length latestBlocks') + buffer
    where
        latestBlocks' = withDefault [] (state ^. latestBlocks)

-- | Determines the `offset` to request pagination of blocks
offsetPaginateBlocksRequest :: State -> Int
offsetPaginateBlocksRequest state =
    length $ withDefault [] (state ^. latestBlocks)

module Explorer.Update where

import Prelude
import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime, NOW)
import Control.SocketIO.Client (SocketIO, emit, emit')
import DOM (DOM)
import DOM.HTML.HTMLElement (blur)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, length, take, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
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, fetchLatestBlocks, fetchLatestTxs, fetchTotalBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Types (RequestLimit(..), RequestOffset(..), SocketSubscription(..), SocketSubscriptionAction(..))
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 (addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewLoadingBlockPagination, dbViewNextBlockPagination, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, lang, latestBlocks, latestTransactions, loading, pullLatestBlocks, pullLatestTxs, route, socket, subscriptions, syncAction, totalBlocks, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), State)
import Explorer.Util.Config (SyncAction(..), syncByPolling, syncBySocket)
import Explorer.Util.DOM (scrollTop, targetToHTMLElement, targetToHTMLInputElement)
import Explorer.Util.Data (sortBlocksByEpochSlot', sortTxsByTime', unionBlocks, unionTxs)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Blocks (maxBlockRows)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Explorer.View.Dashboard.Transactions (maxTransactionRows)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), isNotAsked, isSuccess, withDefault)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, caAddress)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.Router (navigateTo) as P

update :: forall eff. Action -> State ->
    EffModel State Action
    (dom :: DOM
    , ajax :: AJAX
    , socket :: SocketIO
    , now :: NOW
    -- , console :: CONSOLE
    | 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 SocketReconnectSubscriptions
            else pure NoOp
          ]
    }

update (SocketBlocksUpdated (Right blocks)) state =
    noEffects $
    set latestBlocks (Success newBlocks) $
    set totalBlocks (Success newTotalBlocks) state
    where
        previousBlocks = withDefault [] $ state ^. latestBlocks
        newBlocks = sortBlocksByEpochSlot' $ unionBlocks blocks previousBlocks
        previousTotalBlocks = withDefault 0 $ state ^. totalBlocks
        newTotalBlocks = (length newBlocks) - (length previousBlocks) + previousTotalBlocks

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

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

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

update (SocketUpdateSubscriptions nextSubs subAction ) state =
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                case subAction of
                    UnsubscribePrevSubscriptions -> do
                        unsubPrevSubscriptions socket'
                        subNextSubscriptions socket'
                    KeepPrevSubscriptions ->
                        subNextSubscriptions socket'
              Nothing -> pure unit
          pure NoOp
    ]}
        where
            currentSubs = state ^. socket <<< subscriptions
            diffNextFromCurrentSubs = difference currentSubs nextSubs
            unsubPrevSubscriptions socket'' =
                traverse_ (liftEff <<< emit' socket'' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
            diffCurrentFromNextSubs = difference nextSubs currentSubs
            subNextSubscriptions socket'' =
                traverse_ (liftEff <<< emit' socket'' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) currentSubs
              Nothing -> pure unit
          pure NoOp
    ]}

-- Dashboard

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

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

update (DashboardPaginateBlocks newPage) state =
    { state:
          if doRequest
          then set (dashboardViewState <<< dbViewNextBlockPagination) newPage state
          else set (dashboardViewState <<< dbViewBlockPagination) newPage state
    , effects:
          if doRequest
          then [ pure $ RequestPaginatedBlocks (RequestLimit limit) (RequestOffset offset) ]
          else []
    }
    where
        doRequest = doPaginateBlocksRequest state newPage maxBlockRows
        buffer = maxBlockRows
        limit = limitPaginateBlocksRequest state newPage maxBlockRows buffer
        offset = offsetPaginateBlocksRequest state

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

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

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

-- Address

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

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

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

-- Block

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

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

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

-- Blocks

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

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

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

-- 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 NoOp ]
            SyncBySocket -> [ liftEff scrollTop >>= \_ -> pure NoOp ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure NoOp
        ]
    }
update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure NoOp
        ]
    }
update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure NoOp
        ]
    }

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

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value state

update GlobalSearch 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 $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Address $ mkCAddress query) *> pure NoOp
          SearchTx ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Tx $ mkCTxId query) *> pure NoOp
          _ -> pure NoOp  -- TODO (ks) maybe put up a message?
      ]
    }
update GlobalSearchTime 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 $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochSlotUrl) *> pure NoOp
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochUrl) *> pure NoOp

            _ -> pure NoOp -- 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 RequestTotalBlocks state =
    { state:
          set totalBlocks Loading state
    , effects:
          [ attempt fetchTotalBlocks >>= pure <<< ReceiveTotalBlocks
          ]
    }

update (ReceiveTotalBlocks (Right total)) state =
    { state:
          set totalBlocks (Success total) state
    , effects:
        -- request `latestBlocks` if needed only
        if isNotAsked $ state ^. latestBlocks
        then [ pure RequestInitialBlocks ]
        else []
    }

update (ReceiveTotalBlocks (Left error)) state =
    noEffects $
    set totalBlocks (Failure error)
    $ over errors (\errors' -> (show error) : errors') state

update RequestInitialBlocks state =
    { state:
          set loading true $
          set latestBlocks Loading
          state
    , effects:
        [ attempt (fetchLatestBlocks (RequestLimit maxBlockRows) (RequestOffset 0)) >>=
            pure <<< ReceiveInitialBlocks
        ]
    }

update (ReceiveInitialBlocks (Right blocks)) state =
    { state:
          set loading false $
          -- add blocks
          set latestBlocks (Success $ sortBlocksByEpochSlot' blocks) $
          set pullLatestBlocks (syncByPolling $ state ^. syncAction)
          state
    , effects:
          -- add subscription of `SubBlock` if we are on `Dashboard` only
          if (state ^. route) == Dashboard
          then  [ pure $ SocketUpdateSubscriptions
                            [ SocketSubscription SubBlock ]
                            KeepPrevSubscriptions
                ]
          else []
    }

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set latestBlocks (Failure error) $
    set pullLatestBlocks (syncByPolling $ state ^. syncAction) $
    over errors (\errors' -> (show error) : errors') state

-- START #Pulling blocks
-- Pulling blocks is just a workaround to avoid issues w/ socket-io
-- TODO (jk) Remove this workaround if socket-io is back
update RequestBlocksUpdate state =
     { state:
           set loading true $
           -- _Important note_:
           -- Don't do `set latestBlocks Loading` here,
           -- we will empty `latestBlocks` in this case !!!
           state
     , effects: [ attempt (fetchLatestBlocks (RequestLimit 10) (RequestOffset 0)) >>= pure <<< ReceiveBlocksUpdate ]
     }

update (ReceiveBlocksUpdate (Right blocks)) state =
    noEffects $
    set loading false <<<
    set latestBlocks (Success newBlocks) $
    set totalBlocks (Success newTotalBlocks) state
    where
        previousBlocks = withDefault [] $ state ^. latestBlocks
        newBlocks = sortBlocksByEpochSlot' $ unionBlocks blocks previousBlocks
        previousTotalBlocks = withDefault 0 $ state ^. totalBlocks
        newTotalBlocks = (length newBlocks) - (length previousBlocks) + previousTotalBlocks

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

-- END #Pulling blocks

update (RequestPaginatedBlocks limit offset) 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 (fetchLatestBlocks limit offset) >>= pure <<< ReceivePaginatedBlocks ]
    }

update (ReceivePaginatedBlocks (Right blocks)) state =
    noEffects $
    set loading false $
    set (dashboardViewState <<< dbViewBlockPagination) (state ^. (dashboardViewState <<< dbViewNextBlockPagination)) $
    set (dashboardViewState <<< dbViewLoadingBlockPagination) false $
    set latestBlocks (Success newBlocks) state
    where
        previousBlocks = withDefault [] $ state ^. latestBlocks
        newBlocks = sortBlocksByEpochSlot' $ unionBlocks blocks previousBlocks

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 $ state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Just blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    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 <<< 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 $ state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Just txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs Nothing $
    over errors (\errors' -> (show error) : errors') state

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

update (ReceiveInitialTxs (Right txs)) state =
    { state:
          set loading false $
          set pullLatestTxs (syncByPolling $ state ^. syncAction) $
          over latestTransactions
              (\currentTxs -> Success <<<
                                  sortTxsByTime' <<<
                                  take maxTransactionRows $
                                      unionTxs txs $
                                          withDefault [] currentTxs
              )
          state
    , effects:
          -- add subscription of `SubTx` if we are on `Dashboard` only
          if (state ^. route) == Dashboard
          then [ pure $ SocketUpdateSubscriptions
                            [ SocketSubscription SubTx]
                            KeepPrevSubscriptions
                ]
          else []

    }

update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false $
    set pullLatestTxs (syncByPolling $ state ^. syncAction) $
    over errors (\errors' -> (show error) : errors') state

-- START #Pulling txs
-- It is just a workaround to avoid issues w/ socket-io
-- TODO (jk) Remove this workaround if socket-io will be fixed
update RequestTxsUpdate state =
     { state:
           set loading true
           -- _Important note_:
           -- Don't do `set latestTransactions Loading` here,
           -- we will have an empty `latestTransactions` in this case !!!
           state
     , effects:
          [ attempt (fetchLatestTxs (RequestLimit 10) (RequestOffset 0)) >>=
                pure <<< ReceiveTxsUpdate
          ]
     }

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

update (ReceiveTxsUpdate (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 <<< 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 <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure $ GenerateQrCode $ address ^. (_CAddressSummary <<< 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
         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 (UpdateView route) state = routeEffects route (state { route = route })

routeEffects :: forall eff. Route -> State -> EffModel State Action (dom :: DOM
    , ajax :: AJAX | eff)
routeEffects Dashboard state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        ]
        -- get `totalBlocks` only once
        <>  ( if isNotAsked $ state ^. totalBlocks
              then [ pure RequestTotalBlocks ]
              else []
            )
        -- request `latestBlocks` if needed
        <>  ( if  (isSuccess $ state ^. totalBlocks) &&
                  (isNotAsked $ state ^. latestBlocks) &&
                  (not $ state ^. pullLatestBlocks)
              then [ pure RequestInitialBlocks ]
              else []
            )
        -- pull latest blocks if needed
        <>  ( if  (syncByPolling $ state ^. syncAction) &&
                  (state ^. pullLatestBlocks)
              then [ pure RequestBlocksUpdate ]
              else []
            )
        -- request `latestTransactions` if needed
        <>  ( if (isNotAsked $ state ^. latestTransactions) &&
                  (not $ state ^. pullLatestTxs)
              then [ pure RequestInitialTxs ]
              else []
            )
        -- pull latest txs if needed
        <>  ( if  (syncByPolling $ state ^. syncAction) &&
                  (state ^. pullLatestTxs)
              then [ pure RequestTxsUpdate ]
              else []
            )
        -- subscribe to `SubBlock` and `SubTx `if needed
        <>  ( if  (syncBySocket $ state ^. syncAction) &&
                  (isSuccess $ state ^. latestBlocks) &&
                  (isSuccess $ state ^. latestTransactions)
              then [ pure $ SocketUpdateSubscriptions
                              [ SocketSubscription SubBlock
                              , SocketSubscription SubTx
                              ] UnsubscribePrevSubscriptions
                  ]
              else []
            )
    }

routeEffects (Tx tx) state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestTxSummary tx
        ]
    }

routeEffects (Address cAddress) state =
    { state:
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestAddressSummary cAddress
        ]
    }

routeEffects (Epoch epochIndex) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex Nothing
        ]
    }

routeEffects (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)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

routeEffects Calculator state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang)
            state
    , effects: [ pure ScrollTop ]
    }

routeEffects (Block hash) state =
    { state:
        set currentBlockSummary Nothing $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

routeEffects Playground state =
    { state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        ]
    }

routeEffects NotFound state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [] UnsubscribePrevSubscriptions
        ]
    }

-- helper functions

-- | Checks if we do need to make a request to get data of next block pagination or not
doPaginateBlocksRequest :: State -> Int -> Int -> Boolean
doPaginateBlocksRequest state nextPage blockRows =
    nextPage > state ^. (dashboardViewState <<< dbViewBlockPagination)
    && lengthBlocks < (nextPage * blockRows)
    && lengthBlocks < (withDefault 0 $ state ^. totalBlocks)
    where
        lengthBlocks = length $ withDefault [] (state ^. latestBlocks)

-- | Determines the `limit` to request pagination of blocks
-- | _Note_: We add some extra "buffer" to get more blocks as needed,
-- | just to avoid to lost any data
limitPaginateBlocksRequest :: State -> Int -> Int -> Int -> Int
limitPaginateBlocksRequest state nextPage blockRows buffer =
    (nextPage * blockRows - length latestBlocks') + buffer
    where
        latestBlocks' = withDefault [] (state ^. latestBlocks)

-- | Determines the `offset` to request pagination of blocks
offsetPaginateBlocksRequest :: State -> Int
offsetPaginateBlocksRequest state =
    length $ withDefault [] (state ^. latestBlocks)


Fix some warnings

Fix some warnings

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Dashboard.Menu.Component.State where

import Prelude

import Data.Maybe (Maybe(..))
import Data.StrMap as StrMap

import Halogen.Menu.Component as HalogenMenu
import Halogen.Menu.Component.State as HalogenMenu

import Dashboard.Component.State (NotebookShortcut())
import Dashboard.Menu.Component.Query
import Dashboard.Rename.Component as Rename

type StateP g = HalogenMenu.MenuP (Maybe Value) g

make :: (StrMap.StrMap NotebookShortcut) -> HalogenMenu.Menu (Maybe Value)
make shortcuts = HalogenMenu.makeMenu
  [ { label: "Notebook"
    , submenu:
        [ { label: "Rename/Move"
          , shortcutLabel: Nothing
          , value: Just $ renameQueryToValue $ Rename.Focus unit
          }
        , { label: "Delete"
          , shortcutLabel: Nothing
          , value: Nothing
          }
        , { label: "Publish"
          , shortcutLabel: StrMap.lookup "NotebookPublish" shortcuts >>= _.label
          , value: StrMap.lookup "NotebookPublish" shortcuts >>= _.value >>> pure
          }
        ]
    }
  , { label: "Insert"
    , submenu:
        [ { label: "Query"
          , shortcutLabel: StrMap.lookup "InsertQuery" shortcuts >>= _.label
          , value: StrMap.lookup "InsertQuery" shortcuts >>= _.value >>> pure
          }
        , { label: "Markdown"
          , shortcutLabel: StrMap.lookup "InsertMarkdown" shortcuts >>= _.label
          , value: StrMap.lookup "InsertMarkdown" shortcuts >>= _.value >>> pure
          }
        , { label: "Explore"
          , shortcutLabel: StrMap.lookup "InsertExplore" shortcuts >>= _.label
          , value: StrMap.lookup "InsertExplore" shortcuts >>= _.value >>> pure
          }
        , { label: "Search"
          , shortcutLabel: StrMap.lookup "InsertSearch" shortcuts >>= _.label
          , value: StrMap.lookup "InsertSearch" shortcuts >>= _.value >>> pure
          }
        ]
    }
  , { label: "Cell"
    , submenu:
        [ { label: "Evaluate"
          , shortcutLabel: StrMap.lookup "CellEvaluate" shortcuts >>= _.label
          , value: StrMap.lookup "CellEvaluate" shortcuts >>= _.value >>> pure
          }
        , { label: "Delete"
          , shortcutLabel: Nothing
          , value: Nothing
          }
        ]
    }
  , { label: "Help"
    , submenu:
        [ { label: "Getting started"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/"
          }
        , { label: "Manual"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/front-end-manual/"
          }
        , { label: "SlamSQL reference"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/slamsql-reference/"
          }
        , { label: "SlamDown reference"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/slamdown-reference/"
          }
        , { label: "Cheatsheet"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/support/cheatsheet.pdf"
          }
        , { label: "How to guides"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/how-tos/"
          }
        , { label: "Securing access to SlamData"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/quick-guide-resources/"
          }
        , { label: "Report a bug"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "mailto:support@slamdata.com?subject=Bug found"
          }
        , { label: "Request support"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "mailto:support@slamdata.com?subject=Request help"
          }
        ]
    }
  ]

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Dashboard.Menu.Component.State where

import Prelude

import Data.Maybe (Maybe(..))
import Halogen.Menu.Component as HalogenMenu
import Halogen.Menu.Component.State as HalogenMenu
import Data.StrMap as StrMap

import Notebook.Cell.CellType (CellType(..))
import Notebook.Component as Notebook
import Dashboard.Component.State (NotebookShortcut())
import Dashboard.Menu.Component.Query
import Dashboard.Rename.Component as Rename

type StateP g = HalogenMenu.MenuP (Maybe Value) g

make :: (StrMap.StrMap NotebookShortcut) -> HalogenMenu.Menu (Maybe Value)
make shortcuts = HalogenMenu.makeMenu
  [ { label: "Notebook"
    , submenu:
        [ { label: "Rename/Move"
          , shortcutLabel: Nothing
          , value: Just $ renameQueryToValue $ Rename.Focus unit
          }
        , { label: "Delete"
          , shortcutLabel: Nothing
          , value: Nothing
          }
        , { label: "Publish"
          , shortcutLabel: StrMap.lookup "NotebookPublish" shortcuts >>= _.label
          , value: StrMap.lookup "NotebookPublish" shortcuts >>= _.value >>> pure
          }
        ]
    }
  , { label: "Insert"
    , submenu:
        [ { label: "Query"
          , shortcutLabel: StrMap.lookup "InsertQuery" shortcuts >>= _.label
          , value: StrMap.lookup "InsertQuery" shortcuts >>= _.value >>> pure
          }
        , { label: "Markdown"
          , shortcutLabel: StrMap.lookup "InsertMarkdown" shortcuts >>= _.label
          , value: StrMap.lookup "InsertMarkdown" shortcuts >>= _.value >>> pure
          }
        , { label: "Explore"
          , shortcutLabel: StrMap.lookup "InsertExplore" shortcuts >>= _.label
          , value: StrMap.lookup "InsertExplore" shortcuts >>= _.value >>> pure
          }
        , { label: "Search"
          , shortcutLabel: StrMap.lookup "InsertSearch" shortcuts >>= _.label
          , value: StrMap.lookup "InsertSearch" shortcuts >>= _.value >>> pure
          }
        ]
    }
  , { label: "Cell"
    , submenu:
        [ { label: "Evaluate"
          , shortcutLabel: StrMap.lookup "CellEvaluate" shortcuts >>= _.label
          , value: StrMap.lookup "CellEvaluate" shortcuts >>= _.value >>> pure
          }
        , { label: "Delete"
          , shortcutLabel: Nothing
          , value: Nothing
          }
        ]
    }
  , { label: "Help"
    , submenu:
        [ { label: "Getting started"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/"
          }
        , { label: "Manual"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/front-end-manual/"
          }
        , { label: "SlamSQL reference"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/slamsql-reference/"
          }
        , { label: "SlamDown reference"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/slamdown-reference/"
          }
        , { label: "Cheatsheet"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/support/cheatsheet.pdf"
          }
        , { label: "How to guides"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/how-tos/"
          }
        , { label: "Securing access to SlamData"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "http://slamdata.com/documentation/quick-guide-resources/"
          }
        , { label: "Report a bug"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "mailto:support@slamdata.com?subject=Bug found"
          }
        , { label: "Request support"
          , shortcutLabel: Nothing
          , value: Just $ helpURIToValue $ HelpURI "mailto:support@slamdata.com?subject=Request help"
          }
        ]
    }
  ]


Fix autocompleteAddImport check. Fixes #73.

module LanguageServer.IdePurescript.Imports where

import Prelude
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readString, toForeign)
import Data.Maybe (Maybe(..))
import Data.Nullable (toNullable)
import IdePurescript.Modules (ImportResult(..), addExplicitImport)
import IdePurescript.PscIdeServer (ErrorLevel(..), Notify)
import IdePurescript.VSCode.Text (makeMinimalWorkspaceEdit)
import LanguageServer.DocumentStore (getDocument)
import LanguageServer.Handlers (applyEdit)
import LanguageServer.IdePurescript.Config (autocompleteAddImport)
import LanguageServer.IdePurescript.Types (MainEff, ServerState(..))
import LanguageServer.TextDocument (getText, getVersion)
import LanguageServer.Types (DocumentStore, DocumentUri(..), Settings)

addCompletionImport :: forall eff. Notify (MainEff eff) -> DocumentStore -> Settings -> ServerState (MainEff eff) -> Array Foreign -> Aff (MainEff eff) Foreign
addCompletionImport log docs config state args = do
  let shouldAddImport = autocompleteAddImport config
      ServerState { port, modules, conn } = state
  case port, (runExcept <<< readString) <$> args, shouldAddImport of
    Just port', [ Right identifier, mod', Right uri ], true -> do
      let mod'' = either (const Nothing) Just mod'
      doc <- liftEff $ getDocument docs (DocumentUri uri)
      version <- liftEff $ getVersion doc
      text <- liftEff $ getText doc
      { state: modulesState', result } <- addExplicitImport modules port' uri text mod'' identifier
      liftEff $ case result of
        UpdatedImports newText -> do
          let edit = makeMinimalWorkspaceEdit (DocumentUri uri) version text newText
          case conn, edit of
            Just conn', Just edit' -> applyEdit conn' edit'
            _, _ -> pure unit
          pure successResult
        AmbiguousImport imps ->  do
          log Warning "Found ambiguous imports"
          pure $ toForeign $ (\(C.TypeInfo { module' }) -> module') <$> imps
        FailedImport -> log Error "Failed to import" $> successResult
    _, args', _ -> do
      when shouldAddImport $ liftEff $ log Info $ show args'
      pure successResult

    where
    successResult = toForeign $ toNullable Nothing

module LanguageServer.IdePurescript.Imports where

import Prelude
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readString, toForeign)
import Data.Maybe (Maybe(..))
import Data.Nullable (toNullable)
import IdePurescript.Modules (ImportResult(..), addExplicitImport)
import IdePurescript.PscIdeServer (ErrorLevel(..), Notify)
import IdePurescript.VSCode.Text (makeMinimalWorkspaceEdit)
import LanguageServer.DocumentStore (getDocument)
import LanguageServer.Handlers (applyEdit)
import LanguageServer.IdePurescript.Config (autocompleteAddImport)
import LanguageServer.IdePurescript.Types (MainEff, ServerState(..))
import LanguageServer.TextDocument (getText, getVersion)
import LanguageServer.Types (DocumentStore, DocumentUri(..), Settings)

addCompletionImport :: forall eff. Notify (MainEff eff) -> DocumentStore -> Settings -> ServerState (MainEff eff) -> Array Foreign -> Aff (MainEff eff) Foreign
addCompletionImport log docs config state args = do
  let shouldAddImport = autocompleteAddImport config
      ServerState { port, modules, conn } = state
  case port, (runExcept <<< readString) <$> args of
    Just port', [ Right identifier, mod', Right uri ] -> do
      let mod'' = either (const Nothing) Just mod'
      doc <- liftEff $ getDocument docs (DocumentUri uri)
      version <- liftEff $ getVersion doc
      text <- liftEff $ getText doc
      { state: modulesState', result } <- addExplicitImport modules port' uri text mod'' identifier
      liftEff $ case result of
        UpdatedImports newText -> do
          let edit = makeMinimalWorkspaceEdit (DocumentUri uri) version text newText
          case conn, edit of
            Just conn', Just edit' -> applyEdit conn' edit'
            _, _ -> pure unit
          pure successResult
        AmbiguousImport imps ->  do
          log Warning "Found ambiguous imports"
          pure $ toForeign $ (\(C.TypeInfo { module' }) -> module') <$> imps
        FailedImport -> log Error "Failed to import" $> successResult
    _, args' -> do
      liftEff $ log Info $ show args'
      pure successResult

    where
    successResult = toForeign $ toNullable Nothing


Extending the Gauge functionality

Extending the Gauge functionality

module Gauge where

import Prelude
import Data.Maybe
import Data.Monoid
import Data.Functor
import Control.Monad.Eff.Exception
import Data.List as L
import Data.Map as Map
import Control.Bind ((=<<))
import Data.Eq (Eq)
import Data.Foldable (sum)
import Data.List (concatMap)
import Data.Map (Map, alter, fromFoldable, update)

import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Events as E

import React.DOM.Props (onChange)

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate deriving Eq

data Action = UpdateStats (List NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: List NodeStats }

-- /todo: Add Node = String | IPAddress
type Node = String
type Broker =
    { name :: Node
    , port :: Int }
type BStats = Int
type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: List BrokerStats}

init :: State
init = { viewType : PerBroker, stats : Nil }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (List NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # show <<< numConnections

viewAs :: ViewType -> (List NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    s # map \{node,brokers} ->
        let agg = brokers # map _.connections # sum in
        H.div []
            [ H.h1  [] [text $ show node]
            , viewStats agg ]

viewAs PerBroker s =
    let mergeBrokerStats {broker, connections} = addOrInsert broker connections
        statsPerBroker = s # concatMap _.brokers
                            >>> foldl mergeBrokerStats Map.empty
                            >>> Map.toAscUnfoldable
    in
    H.div []
    statsPerBroker
    # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [text $ show broker]
            , viewStats agg]

viewAs PerNodeAndBroker s =
    H.div []
    []

viewAs Aggregate s =
    let agg = s # numConnections in
    H.div []
        [ H.h1  [] [text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [text "Connections:"]
        , H.p  [] [text  stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.select
     [E.onSelect changeView]
     (optionView <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView v sel =
    let strVal = viewTypeToStr v in
    H.option [A.value strVal, A.selected (v == sel) ] [H.text strVal]

changeView :: E.SelectionEvent -> Action
changeView se =
    ChangeView (toViewType se.target.value)

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

viewTypeToStr:: ViewType -> String
viewTypeToStr = show

toViewType :: String -> ViewType
toViewType "PerNode" = PerNode
toViewType "PerBroker" = PerBroker
toViewType "PerNodeAndBroker" = PerNodeAndBroker
toViewType "Aggregate" = Aggregate
toViewType _ = Aggregate

instance viewTypeShow :: Show ViewType where
  show PerNode = "PerNode"
  show PerBroker = "PerBroker"
  show PerNodeAndBroker = "PerNodeAndBroker"
  show Aggregate = "Aggregate"

numConnections :: List NodeStats -> Int
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> sum

-- latestStatsPerBroker :: NodeStats -> List BrokerStats
-- latestStatsPerBroker =
--      _.timedSeries
--         >>> head
--         >>> map _.value
--         >>> emptyIfNothing

-- latestStatsPerBroker :: NodeStats -> List BrokerStats
-- latestStatsPerBroker =
--      _.timedSeries
--         >>> head
--         >>> map _.value
--         >>> emptyIfNothing

upsert :: forall k v. Monoid v => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

addOrInsert :: forall k v. Monoid v => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<#>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty

module Gauge where

import Prelude
import Data.List
import Data.Maybe
import Data.Functor
import Control.Monad.Eff.Exception
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Control.Bind ((=<<))
import Data.Foldable (sum)
import Data.Eq (Eq)

import React.DOM.Props (onChange)

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate deriving Eq

data Action = UpdateStats (List NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: List NodeStats }

-- /todo: Add Node = String | IPAddress
type Node = String
type Broker =
    { name :: Node
    , port :: Int }
type BStats = Int
type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , timedSeries:: List (TimedVal (List BrokerStats))}

instance viewTypeShow :: Show ViewType where
  show PerNode = "PerNode"
  show PerBroker = "PerBroker"
  show PerNodeAndBroker = "PerNodeAndBroker"
  show Aggregate = "Aggregate"

numConnections :: List NodeStats -> Int
numConnections =
    concatMap latestStatsPerBroker
    >>> map _.connections
    >>> sum

-- numConnections :: List BrokerStats -> Int
-- numConnections =
--     map _.connections >>> sum

latestStatsPerBroker :: NodeStats -> List BrokerStats
latestStatsPerBroker =
     _.timedSeries
        >>> head
        >>> map _.value
        >>> emptyIfNothing

-- latestStatsPerBroker :: List(NodeStats) -> List BrokerStats
-- latestStatsPerBroker =
--     map latestStatsPerBroker
--     >>> group _.broker
--     >>> {broker : b, connections : }

emptyIfNothing :: forall a. Maybe (List a) -> List a
emptyIfNothing (Just x) = x
emptyIfNothing Nothing = Nil

init :: State
init = { viewType : PerBroker, stats : Nil }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div
    []
    [ H.h1 [] [numConnectionsView stats]
    , select viewType
    , stats # viewAs viewType
    ]

numConnectionsView :: (List NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # show <<< numConnections

viewAs :: ViewType ->  (List NodeStats) -> H.Html Action
viewAs PerNode s = H.div [] []
viewAs PerBroker s = H.div [] []
viewAs PerNodeAndBroker s = H.div [] []
viewAs Aggregate s = H.div [] []

select :: ViewType -> H.Html Action
select viewType =
    H.select
     [E.onSelect changeView]
     (optionView <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView v sel =
    let strVal = viewTypeToStr v in
    H.option [A.value strVal, A.selected (v == sel) ] [H.text strVal]

changeView :: E.SelectionEvent -> Action
changeView se =
    ChangeView (toViewType se.target.value)

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

viewTypeToStr:: ViewType -> String
viewTypeToStr = show

toViewType :: String -> ViewType
toViewType "PerNode" = PerNode
toViewType "PerBroker" = PerBroker
toViewType "PerNodeAndBroker" = PerNodeAndBroker
toViewType "Aggregate" = Aggregate
toViewType _ = Aggregate