[CSE-98] Don't optimize requests

[CSE-98] Don't optimize requests

module Explorer.Update where

import Prelude
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.SocketIO.Client (SocketIO, emit, emit')
import Control.Comonad (extract)
import DOM (DOM)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, (:))
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, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
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, blockDetail, blockTxPagination, blocksViewState, blsViewPagination, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlocksExpanded, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, handleLatestBlocksSocketResult, handleLatestTxsSocketResult, initialBlocksRequested, initialTxsRequested, lang, latestBlocks, latestTransactions, loading, socket, subscriptions, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), SocketSubscription(..), State)
import Explorer.Util.DOM (scrollTop)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), _Success)
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
import Control.Monad.Eff.Now (nowDateTime, NOW)

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 $
    if state ^. handleLatestBlocksSocketResult
    -- add incoming blocks ahead of previous blocks
    then over (latestBlocks <<< _Success) (\b -> blocks <> b) state
    else state
update (SocketBlocksUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update (SocketTxsUpdated (Right transactions)) state = noEffects $
    -- add incoming transactions ahead of previous transactions
    over latestTransactions (\t -> transactions <> t) 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) state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- 1. unsubscribe all not used events
                let diffNextFromCurrentSubs = difference currentSubs nextSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
                -- 2. subscribe all new subscriptions
                let diffCurrentFromNextSubs = difference nextSubs currentSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs
              Nothing -> pure unit
          pure NoOp
    ]}

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 value) state = noEffects $
    set (dashboardViewState <<< dbViewBlockPagination) value state
update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

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

-- Block

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

-- Blocks

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

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        -- FIXME: scrollTop disabled as a workaround for socketio
        [ -- liftEff scrollTop >>= \_ -> pure NoOp
        ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> 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 RequestInitialBlocks state =
    { state: set loading true $ state
    , effects: [ attempt fetchLatestBlocks >>= pure <<< ReceiveInitialBlocks ]
    }
update (ReceiveInitialBlocks (Right blocks)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    set latestBlocks (Success blocks) $
    state

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    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 state
    , effects: [ attempt fetchLatestTxs >>= pure <<< ReceiveInitialTxs ]
    }
update (ReceiveInitialTxs (Right blocks)) state =
    noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over latestTransactions (\b -> blocks <> b) state
update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state: set loading true 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 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 }

-- socket-io workaround
update ReloadSignal 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
        , pure $ SocketUpdateSubscriptions [ SocketSubscription SubBlock, SocketSubscription SubTx ]
        , pure RequestInitialBlocks
        , pure RequestInitialTxs
        ]
    }

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

routeEffects (Address cAddress) state =
    { state:
        set currentAddressSummary Loading $
        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 []
        , 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 []
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

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

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

module Explorer.Update where

import Prelude
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.SocketIO.Client (SocketIO, emit, emit')
import Control.Comonad (extract)
import DOM (DOM)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, (:))
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, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
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, blockDetail, blockTxPagination, blocksViewState, blsViewPagination, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlocksExpanded, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, handleLatestBlocksSocketResult, handleLatestTxsSocketResult, initialBlocksRequested, initialTxsRequested, lang, latestBlocks, latestTransactions, loading, socket, subscriptions, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), SocketSubscription(..), State)
import Explorer.Util.DOM (scrollTop)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), _Success)
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
import Control.Monad.Eff.Now (nowDateTime, NOW)

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 $
    if state ^. handleLatestBlocksSocketResult
    -- add incoming blocks ahead of previous blocks
    then over (latestBlocks <<< _Success) (\b -> blocks <> b) state
    else state
update (SocketBlocksUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update (SocketTxsUpdated (Right transactions)) state = noEffects $
    -- add incoming transactions ahead of previous transactions
    over latestTransactions (\t -> transactions <> t) 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) state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- 1. unsubscribe all not used events
                let diffNextFromCurrentSubs = difference currentSubs nextSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
                -- 2. subscribe all new subscriptions
                let diffCurrentFromNextSubs = difference nextSubs currentSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs
              Nothing -> pure unit
          pure NoOp
    ]}

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 value) state = noEffects $
    set (dashboardViewState <<< dbViewBlockPagination) value state
update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

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

-- Block

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

-- Blocks

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

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        -- FIXME: scrollTop disabled as a workaround for socketio
        [ -- liftEff scrollTop >>= \_ -> pure NoOp
        ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> 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 RequestInitialBlocks state =
    { state: set loading true $ state
    , effects: [ attempt fetchLatestBlocks >>= pure <<< ReceiveInitialBlocks ]
    }
update (ReceiveInitialBlocks (Right blocks)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    set latestBlocks (Success blocks) $
    state

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    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 state
    , effects: [ attempt fetchLatestTxs >>= pure <<< ReceiveInitialTxs ]
    }
update (ReceiveInitialTxs (Right blocks)) state =
    noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over latestTransactions (\b -> blocks <> b) state
update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state: set loading true 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 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 }

-- socket-io workaround
update ReloadSignal 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
        , pure $ SocketUpdateSubscriptions [ SocketSubscription SubBlock, SocketSubscription SubTx ]
        , if not $ state ^. initialBlocksRequested
          then pure RequestInitialBlocks
          else pure NoOp
        , if not $ state ^. initialTxsRequested
          then pure RequestInitialTxs
          else pure NoOp
        ]
    }

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

routeEffects (Address cAddress) state =
    { state:
        set currentAddressSummary Loading $
        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 []
        , 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 []
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

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

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


removes overlapping Field instance

removes overlapping Field instance

module Test.StrongCheck.Data.ApproxNumber where

import Prelude

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

-- | A newtype for `Number` whose `Eq` instance uses an epsilon value to allow
-- | for precision erros when comparing.
newtype ApproxNumber = ApproxNumber Number

-- Approximate equality comparison
approximateEqual :: Number -> Number -> Boolean
approximateEqual x y = (y - x) <= epsilon && (y - x) >= (-epsilon)
  where
  epsilon = 0.00000001

infix 2 approximateEqual as =~=

instance arbitraryApproxNumber :: Arbitrary ApproxNumber where
  arbitrary = ApproxNumber <$> arbitrary

instance coarbitraryApproxNumber :: Coarbitrary ApproxNumber where
  coarbitrary (ApproxNumber n) = coarbitrary n

instance eqApproxNumber :: Eq ApproxNumber where
  eq (ApproxNumber x) (ApproxNumber y) = x =~= y

instance ordApproxNumber :: Ord ApproxNumber where
  compare (ApproxNumber x) (ApproxNumber y) = compare x y

instance semiringApproxNumber :: Semiring ApproxNumber where
  add (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x + y)
  zero = ApproxNumber zero
  mul (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x * y)
  one = ApproxNumber one

instance ringApproxNumber :: Ring ApproxNumber where
  sub (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x - y)

instance commutativeRingApproxNumber :: CommutativeRing ApproxNumber

instance euclideanRingApproxNumber :: EuclideanRing ApproxNumber where
  degree (ApproxNumber x) = degree x
  div (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x / y)
  mod (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x `mod` y)

instance fieldApproxNumber :: Field ApproxNumber


Use the initialAce state from #4

Use the initialAce state from #4

module Main where

import Prelude

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceState (), AceQuery (), initialAceState)
import qualified Ace.Halogen.Component as Ace

import Control.Monad.Aff (Aff (), runAff)
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Plus (Plus)

import Data.Functor.Coproduct (Coproduct())
import Data.Maybe (Maybe (..))

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H

-- Effects
import Control.Monad.Eff.Random (RANDOM ())
import Control.Monad.Eff.Ref (REF ())
import Ace.Types (ACE ())
import Data.Date (Now ())

data Query a
    = UpdateText a

type State =
    { text :: String
    }

initialState :: State
initialState =
    { text : "Name: Ace Editor"
    }

data AceSlot = AceSlot

instance eqAceSlot :: Eq AceSlot where
    eq AceSlot AceSlot = true

instance ordAceSlot :: Ord AceSlot where
    compare AceSlot AceSlot = EQ

type StateP g = InstalledState State AceState Query AceQuery g AceSlot
type QueryP = Coproduct Query (ChildF AceSlot AceQuery)
type MainHtml g = ParentHTML AceState Query AceQuery g AceSlot
type MainEffects = HalogenEffects (random :: RANDOM, now :: Now, ref :: REF, ace :: ACE)
type MainAff = Aff MainEffects

ui :: Component (StateP MainAff) QueryP MainAff
ui = parentComponent render eval
    where

    render :: State -> MainHtml MainAff
    render state =
        H.div_
            [ H.slot AceSlot \_ ->
                { component :
                    Ace.aceComponent
                        (\editor -> liftEff $ do
                            session <- Editor.getSession editor
                            Session.setMode "ace/mode/yaml" session
                            Editor.setValue state.text Nothing editor
                            pure unit
                        )
                        Nothing
                , initialState :
                    initialAceState
                }
            , H.div_
                [ H.text state.text ]
            ]

    eval :: EvalParent Query State AceState Query AceQuery MainAff AceSlot
    eval (UpdateText next) = do
        pure next

main :: Eff MainEffects Unit
main = runAff throwException (const (pure unit)) $ do
    app <- runUI ui (installedState initialState)
    onLoad $ appendToBody app.node

module Main where

import Prelude

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceState (), AceQuery ())
import qualified Ace.Halogen.Component as Ace

import Control.Monad.Aff (Aff (), runAff)
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Plus (Plus)

import Data.Functor.Coproduct (Coproduct())
import Data.Maybe (Maybe (..))

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H

-- Effects
import Control.Monad.Eff.Random (RANDOM ())
import Control.Monad.Eff.Ref (REF ())
import Ace.Types (ACE ())
import Data.Date (Now ())

data Query a
    = UpdateText a

type State =
    { text :: String
    }

initialState :: State
initialState =
    { text : "Name: Ace Editor"
    }

data AceSlot = AceSlot

instance eqAceSlot :: Eq AceSlot where
    eq AceSlot AceSlot = true

instance ordAceSlot :: Ord AceSlot where
    compare AceSlot AceSlot = EQ

type StateP g = InstalledState State AceState Query AceQuery g AceSlot
type QueryP = Coproduct Query (ChildF AceSlot AceQuery)
type MainHtml g = ParentHTML AceState Query AceQuery g AceSlot
type MainEffects = HalogenEffects (random :: RANDOM, now :: Now, ref :: REF, ace :: ACE)
type MainAff = Aff MainEffects

ui :: Component (StateP MainAff) QueryP MainAff
ui = parentComponent render eval
    where

    render :: State -> MainHtml MainAff
    render state =
        H.div_
            [ H.slot AceSlot \_ ->
                { component :
                    Ace.aceComponent
                        (\editor -> liftEff $ do
                            session <- Editor.getSession editor
                            Session.setMode "ace/mode/yaml" session
                            Editor.setValue state.text Nothing editor
                            pure unit
                        )
                        Nothing
                , initialState :
                    { key : Nothing, editor : Nothing }
                }
            , H.div_
                [ H.text state.text ]
            ]

    eval :: EvalParent Query State AceState Query AceQuery MainAff AceSlot
    eval (UpdateText next) = do
        pure next

main :: Eff MainEffects Unit
main = runAff throwException (const (pure unit)) $ do
    app <- runUI ui (installedState initialState)
    onLoad $ appendToBody app.node


Removes private unYear function

Removes private unYear function

Function is not used anywhere locally, not exported and is superseded by `fromEnum`

module Data.Date.Component
  ( Year
  , Month(..)
  , Day
  , Weekday(..)
  ) where

import Prelude

import Data.Enum (class Enum, class BoundedEnum, toEnum, fromEnum, Cardinality(..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..))

-- | A year component for a date.
-- |
-- | The constructor is private as the `Year` type is bounded to the range
-- | -271820 to 275759, inclusive. The `toEnum` function can be used to safely
-- | acquire a year value from an integer.
newtype Year = Year Int

derive instance eqYear :: Eq Year
derive instance ordYear :: Ord Year
derive instance genericYear :: Generic Year

-- Note: these seemingly arbitrary bounds come from relying on JS for date
-- manipulations, as it only supports date ±100,000,000 days of the Unix epoch.
-- Using these year values means `Date bottom bottom bottom` is a valid date,
-- likewise for `top`.
instance boundedYear :: Bounded Year where
  bottom = Year (-271820)
  top = Year 275759

instance enumYear :: Enum Year where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumYear :: BoundedEnum Year where
  cardinality = Cardinality 547580
  toEnum n
    | n >= (-271821) && n <= 275759 = Just (Year n)
    | otherwise = Nothing
  fromEnum (Year n) = n

instance showYear :: Show Year where
  show (Year y) = "(Year " <> show y <> ")"

-- | A month component for a date in the Gregorian calendar.
data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

derive instance eqMonth :: Eq Month
derive instance ordMonth :: Ord Month
derive instance genericMonth :: Generic Month

instance boundedMonth :: Bounded Month where
  bottom = January
  top = December

instance enumMonth :: Enum Month where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumMonth :: BoundedEnum Month where
  cardinality = Cardinality 12
  toEnum = case _ of
    1 -> Just January
    2 -> Just February
    3 -> Just March
    4 -> Just April
    5 -> Just May
    6 -> Just June
    7 -> Just July
    8 -> Just August
    9 -> Just September
    10 -> Just October
    11 -> Just November
    12 -> Just December
    _ -> Nothing
  fromEnum = case _ of
    January -> 1
    February -> 2
    March -> 3
    April -> 4
    May -> 5
    June -> 6
    July -> 7
    August -> 8
    September -> 9
    October -> 10
    November -> 11
    December -> 12

instance showMonth :: Show Month where
  show January = "January"
  show February = "February"
  show March = "March"
  show April = "April"
  show May = "May"
  show June = "June"
  show July = "July"
  show August = "August"
  show September = "September"
  show October = "October"
  show November = "November"
  show December = "December"

-- | A day component for a date.
-- |
-- | The constructor is private as the `Day` type is bounded to the range
-- | 1 to 31, inclusive. The `toEnum` function can be used to safely
-- | acquire a day value from an integer.
newtype Day = Day Int

derive instance eqDay :: Eq Day
derive instance ordDay :: Ord Day
derive instance genericDay :: Generic Day

instance boundedDay :: Bounded Day where
  bottom = Day 1
  top = Day 31

instance enumDay :: Enum Day where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumDay :: BoundedEnum Day where
  cardinality = Cardinality 31
  toEnum n
    | n >= 1 && n <= 31 = Just (Day n)
    | otherwise = Nothing
  fromEnum (Day n) = n

instance showDay :: Show Day where
  show (Day d) = "(Day " <> show d <> ")"

-- | A type representing the days of the week in the Gregorian calendar.
data Weekday
  = Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  | Sunday

derive instance eqWeekday :: Eq Weekday
derive instance ordWeekday :: Ord Weekday
derive instance genericWeekday :: Generic Weekday

instance boundedWeekday :: Bounded Weekday where
  bottom = Monday
  top = Sunday

instance enumWeekday :: Enum Weekday where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumWeekday :: BoundedEnum Weekday where
  cardinality = Cardinality 7
  toEnum = case _ of
    1 -> Just Monday
    2 -> Just Tuesday
    3 -> Just Wednesday
    4 -> Just Thursday
    5 -> Just Friday
    6 -> Just Saturday
    7 -> Just Sunday
    _ -> Nothing
  fromEnum = case _ of
    Monday -> 1
    Tuesday -> 2
    Wednesday -> 3
    Thursday -> 4
    Friday -> 5
    Saturday -> 6
    Sunday -> 7

instance showWeekday :: Show Weekday where
  show Monday = "Monday"
  show Tuesday = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday = "Thursday"
  show Friday = "Friday"
  show Saturday = "Saturday"
  show Sunday = "Sunday"

module Data.Date.Component
  ( Year
  , Month(..)
  , Day
  , Weekday(..)
  ) where

import Prelude

import Data.Enum (class Enum, class BoundedEnum, toEnum, fromEnum, Cardinality(..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..))

-- | A year component for a date.
-- |
-- | The constructor is private as the `Year` type is bounded to the range
-- | -271820 to 275759, inclusive. The `toEnum` function can be used to safely
-- | acquire a year value from an integer.
newtype Year = Year Int

-- | Lowers a year value to a plain number.
unYear :: Year -> Int
unYear (Year y) = y

derive instance eqYear :: Eq Year
derive instance ordYear :: Ord Year
derive instance genericYear :: Generic Year

-- Note: these seemingly arbitrary bounds come from relying on JS for date
-- manipulations, as it only supports date ±100,000,000 days of the Unix epoch.
-- Using these year values means `Date bottom bottom bottom` is a valid date,
-- likewise for `top`.
instance boundedYear :: Bounded Year where
  bottom = Year (-271820)
  top = Year 275759

instance enumYear :: Enum Year where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumYear :: BoundedEnum Year where
  cardinality = Cardinality 547580
  toEnum n
    | n >= (-271821) && n <= 275759 = Just (Year n)
    | otherwise = Nothing
  fromEnum (Year n) = n

instance showYear :: Show Year where
  show (Year y) = "(Year " <> show y <> ")"

-- | A month component for a date in the Gregorian calendar.
data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

derive instance eqMonth :: Eq Month
derive instance ordMonth :: Ord Month
derive instance genericMonth :: Generic Month

instance boundedMonth :: Bounded Month where
  bottom = January
  top = December

instance enumMonth :: Enum Month where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumMonth :: BoundedEnum Month where
  cardinality = Cardinality 12
  toEnum = case _ of
    1 -> Just January
    2 -> Just February
    3 -> Just March
    4 -> Just April
    5 -> Just May
    6 -> Just June
    7 -> Just July
    8 -> Just August
    9 -> Just September
    10 -> Just October
    11 -> Just November
    12 -> Just December
    _ -> Nothing
  fromEnum = case _ of
    January -> 1
    February -> 2
    March -> 3
    April -> 4
    May -> 5
    June -> 6
    July -> 7
    August -> 8
    September -> 9
    October -> 10
    November -> 11
    December -> 12

instance showMonth :: Show Month where
  show January = "January"
  show February = "February"
  show March = "March"
  show April = "April"
  show May = "May"
  show June = "June"
  show July = "July"
  show August = "August"
  show September = "September"
  show October = "October"
  show November = "November"
  show December = "December"

-- | A day component for a date.
-- |
-- | The constructor is private as the `Day` type is bounded to the range
-- | 1 to 31, inclusive. The `toEnum` function can be used to safely
-- | acquire a day value from an integer.
newtype Day = Day Int

derive instance eqDay :: Eq Day
derive instance ordDay :: Ord Day
derive instance genericDay :: Generic Day

instance boundedDay :: Bounded Day where
  bottom = Day 1
  top = Day 31

instance enumDay :: Enum Day where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumDay :: BoundedEnum Day where
  cardinality = Cardinality 31
  toEnum n
    | n >= 1 && n <= 31 = Just (Day n)
    | otherwise = Nothing
  fromEnum (Day n) = n

instance showDay :: Show Day where
  show (Day d) = "(Day " <> show d <> ")"

-- | A type representing the days of the week in the Gregorian calendar.
data Weekday
  = Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  | Sunday

derive instance eqWeekday :: Eq Weekday
derive instance ordWeekday :: Ord Weekday
derive instance genericWeekday :: Generic Weekday

instance boundedWeekday :: Bounded Weekday where
  bottom = Monday
  top = Sunday

instance enumWeekday :: Enum Weekday where
  succ = toEnum <<< (_ + 1) <<< fromEnum
  pred = toEnum <<< (_ - 1) <<< fromEnum

instance boundedEnumWeekday :: BoundedEnum Weekday where
  cardinality = Cardinality 7
  toEnum = case _ of
    1 -> Just Monday
    2 -> Just Tuesday
    3 -> Just Wednesday
    4 -> Just Thursday
    5 -> Just Friday
    6 -> Just Saturday
    7 -> Just Sunday
    _ -> Nothing
  fromEnum = case _ of
    Monday -> 1
    Tuesday -> 2
    Wednesday -> 3
    Thursday -> 4
    Friday -> 5
    Saturday -> 6
    Sunday -> 7

instance showWeekday :: Show Weekday where
  show Monday = "Monday"
  show Tuesday = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday = "Thursday"
  show Friday = "Friday"
  show Saturday = "Saturday"
  show Sunday = "Sunday"


update comment and fix typo

update comment and fix typo

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, indexl, traverse_)
import Data.Foreign (Foreign)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  -- The hashchange interface is asynchronous, since hashchange events are
  -- fired on the next tick of the event loop. We want the push-state
  -- interface to behave as similarly as possible, so we use `makeImmediate`
  -- which will execute `notify` maximum once per event loop.
  schedule <- makeImmediate $ notify =<< locationState
  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      schedule

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- | Similar to `setImmediate`, it's implemented using microtask queue via MutationObserver
-- | to schedule callbacks. This way it's more immediate than `setTimout` would have been.
-- | We use a fresh counter so that the text change mutation always fires.
-- | from: https://github.com/natefaubion/purescript-spork/blob/3b56c4d36e84866ed9b1bc27afa7ab4762ffdd01/src/Spork/Scheduler.purs#L20
makeImmediate
  ∷ ∀ eff
  . Eff (ref ∷ REF, dom ∷ DOM | eff) Unit
  → Eff (ref ∷ REF, dom ∷ DOM | eff) (Eff (ref ∷ REF, dom ∷ DOM | eff) Unit)
makeImmediate run = do
  document ←
    DOM.window
      >>= DOM.document
      >>> map DOM.htmlDocumentToDocument
  nextTick ← newRef (Right 0)
  obsvNode ← DOM.textToNode <$> DOM.createTextNode "" document
  observer ← DOM.mutationObserver \_ _ → do
    modifyRef nextTick $ either (Right <<< add 1) Right
    run
  DOM.observe obsvNode { characterData: true } observer
  pure do
    readRef nextTick >>= traverse_ \tick → do
      writeRef nextTick $ Left (tick + 1)
      DOM.setNodeValue (show tick) obsvNode

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, indexl, traverse_)
import Data.Foreign (Foreign)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  schedule <- makeImmediate $ notify =<< locationState
  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use something like
      -- `setImmediate` and use `Ref Boolean` to make sure maximum one `notify` is
      -- scheduled per event loop.
      schedule

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- | Similar to `setImmediate`, it's impelemnted using microtask queue via MutationObserver
-- | to schedule callbacks. this way it's more imediate then `setTimout` would have been.
-- | We use a fresh counter so that the text change mutation always fires.
-- | from: https://github.com/natefaubion/purescript-spork/blob/3b56c4d36e84866ed9b1bc27afa7ab4762ffdd01/src/Spork/Scheduler.purs#L20
makeImmediate
  ∷ ∀ eff
  . Eff (ref ∷ REF, dom ∷ DOM | eff) Unit
  → Eff (ref ∷ REF, dom ∷ DOM | eff) (Eff (ref ∷ REF, dom ∷ DOM | eff) Unit)
makeImmediate run = do
  document ←
    DOM.window
      >>= DOM.document
      >>> map DOM.htmlDocumentToDocument
  nextTick ← newRef (Right 0)
  obsvNode ← DOM.textToNode <$> DOM.createTextNode "" document
  observer ← DOM.mutationObserver \_ _ → do
    modifyRef nextTick $ either (Right <<< add 1) Right
    run
  DOM.observe obsvNode { characterData: true } observer
  pure do
    readRef nextTick >>= traverse_ \tick → do
      writeRef nextTick $ Left (tick + 1)
      DOM.setNodeValue (show tick) obsvNode


wip postfunction

wip postfunction

module Requests.Requests where

import Halogen (HalogenEffects())
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E

import Data.Maybe (Maybe(..), maybe)
import Data.Either
import Data.Foreign.Class
import Control.Monad.Aff
import Control.Alt
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Request
import Network.HTTP.Affjax.Response
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.Method (Method(..), methodToString)

import Models.Action
import Models.Message

postWithHeaders :: forall e a b. (Requestable a, Respondable b) => [RequestHeader] -> URL -> a -> Affjax e b
postWithHeaders headers url content =
	affjax $ defaultRequest
		{ method = POST
		, url = url
		, content = Just content
		, headers = headers
		}

handler :: forall eff. String -> E.Event (HalogenEffects (ajax :: AJAX | eff)) Action
handler code = E.yield DoNothing `E.andThen` \_ -> E.async compileAff
	where
	compileAff :: Aff (HalogenEffects (ajax :: AJAX | eff)) Action
	compileAff = do
		result <- post "http://try.purescript.org/compile/text" code
		let response = result.response
		return case readProp "js" response <|> readProp "error" response of
			Right js -> SendMessage $ TextMessage { text: js }
			Left _ -> DoNothing

module Requests.Requests where

import Halogen (HalogenEffects())
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E

import Data.Either
import Data.Foreign.Class
import Control.Monad.Aff
import Control.Alt
import Network.HTTP.Affjax

import Models.Action
import Models.Message

handler :: forall eff. String -> E.Event (HalogenEffects (ajax :: AJAX | eff)) Action
handler code = E.yield DoNothing `E.andThen` \_ -> E.async compileAff
	where
	compileAff :: Aff (HalogenEffects (ajax :: AJAX | eff)) Action
	compileAff = do
		result <- post "http://try.purescript.org/compile/text" code
		let response = result.response
		return case readProp "js" response <|> readProp "error" response of
			Right js -> SendMessage $ TextMessage { text: js }
			Left _ -> DoNothing


Card path suggestion HTML

Card path suggestion HTML

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Reason.Component where

import SlamData.Prelude

import Data.Array as Array
import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CardType

type State =
  { attemptedCardType ∷ CardType
  , reason ∷ String
  , cardPaths ∷ Array (Array CardType)
  }

data Query a = Dismiss a

comp ∷ ∀ g. Functor g ⇒ H.Component State Query g
comp = H.component { render, eval } where

  render ∷ State → H.ComponentHTML Query
  render state =
    HH.div [ HP.classes [ HH.className "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text $ "Couldn't insert a " ++ CardType.cardName state.attemptedCardType ++ " card into this deck" ]
      , HH.div
          [ HP.classes [ HH.className "deck-dialog-body" ] ]
          [ HH.p_
              [ HH.text state.reason
              ]
          , HH.p_ renderCardPathsMessage
          , HH.div_ $ map renderCardPath state.cardPaths
          ]
      , HH.div
          [ HP.classes [ HH.className "deck-dialog-footer" ] ]
          [ HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ $ Dismiss)
              ]
              [ HH.text "Dismiss" ]
          ]
      ]
    where
    renderCardPathsMessage =
      case Array.length state.cardPaths of
        0 → []
        1 → [ HH.text $ "To be able to insert a " ++ CardType.cardName state.attemptedCardType ++ " card here you can add these cards in order first." ]
        n → [ HH.text $ "To insert a " ++ CardType.cardName state.attemptedCardType ++ " card here you can add one of these sets of cards in order first." ]

    renderCardPath cardPath = HH.div [ HP.classes [ HH.className "deck-dialog-cardpath" ] ] $ map renderCard cardPath

    renderCard card =
      HH.div
        [ HP.classes [HH.className "deck-dialog-cardpath-card" ] ]
        [ HH.text $ CardType.cardName card ]

  eval ∷ Natural Query (H.ComponentDSL State Query g)
  eval (Dismiss next) = pure next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Reason.Component where

import SlamData.Prelude

import Data.Array as Array
import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CardType

type State =
  { attemptedCardType ∷ CardType
  , reason ∷ String
  , cardPaths ∷ Array (Array CardType)
  }

data Query a = Dismiss a

comp ∷ ∀ g. Functor g ⇒ H.Component State Query g
comp = H.component { render, eval } where

  render ∷ State → H.ComponentHTML Query
  render state =
    HH.div [ HP.classes [ HH.className "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text $ "Couldn't insert a " ++ CardType.cardName state.attemptedCardType ++ " card into this deck" ]
      , HH.div
          [ HP.classes [ HH.className "deck-dialog-body" ] ]
          [ HH.p_
              [ HH.text state.reason
              ]
          , HH.p_ renderCardPathsMessage
          , HH.div_ $ map renderCardPath state.cardPaths
          ]
      , HH.div
          [ HP.classes [ HH.className "deck-dialog-footer" ] ]
          [ HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ $ Dismiss)
              ]
              [ HH.text "Dismiss" ]
          ]
      ]
    where
    renderCardPathsMessage =
      case Array.length state.cardPaths of
        0 → []
        1 → [ HH.text $ "To insert a " ++ CardType.cardName state.attemptedCardType ++ " card try adding these cards in order first." ]
        n → [ HH.text $ "To insert a " ++ CardType.cardName state.attemptedCardType ++ " card try adding one of these sets of cards in order first." ]

    renderCardPath cardPath = HH.div_ $ map renderCard cardPath

    renderCard card = HH.text ""

  eval ∷ Natural Query (H.ComponentDSL State Query g)
  eval (Dismiss next) = pure next


More resilient peekVar tests

More resilient peekVar tests

In case of deadlocks

module Test.Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, peekVar, killVar)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log) as Eff
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message, try)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parallel, sequential)
import Data.Either (either, fromLeft, fromRight)
import Data.Maybe (Maybe(..))
import Data.Unfoldable (replicate)
import Partial.Unsafe (unsafePartial)

type Test a = forall e. Aff (console :: CONSOLE | e) a
type TestAVar a = forall e. Aff (console :: CONSOLE, avar :: AVAR | e) a

timeout :: Int → TestAVar Unit → TestAVar Unit
timeout ms aff = do
  exn <- makeVar
  clr1 <- forkAff (later' ms (putVar exn (Just "Timed out")))
  clr2 <- forkAff (aff *> putVar exn Nothing)
  res ← takeVar exn
  log (show res)
  case res of
    Nothing -> void (clr1 `cancel` error "Done")
    Just e -> void (clr2 `cancel` error "Done") *> throwError (error e)

replicateArray :: forall a. Int -> a -> Array a
replicateArray = replicate

test_sequencing :: Int -> Test Unit
test_sequencing 0 = log "Done"
test_sequencing n = do
  later' 100 (log (show (n / 10) <> " seconds left"))
  test_sequencing (n - 1)

foreign import synchronousUnexpectedThrowError :: forall e. Eff e Unit

test_makeAff :: Test Unit
test_makeAff = unsafePartial do
  s <- attempt $ makeAff \reject resolve -> resolve "ok"
  log $ "makeAff success is " <> fromRight s

  asyncF <- attempt $ makeAff \reject resolve -> reject (error "ok")
  log $ "makeAff asynchronous failure is " <> message (fromLeft asyncF)

  asyncF' <- attempt $ makeAff \reject resolve -> synchronousUnexpectedThrowError
  log $ "makeAff synchronous failure is " <> message (fromLeft asyncF')

  log "Success: makeAff is ok"

test_pure :: Test Unit
test_pure = do
  pure unit
  pure unit
  pure unit
  log "Success: Got all the way past 4 pures"

test_attempt :: Test Unit
test_attempt = do
  e <- attempt (throwError (error "Oh noes!"))
  either (const $ log "Success: Exception caught") (const $ log "Failure: Exception NOT caught!!!") e

test_apathize :: Test Unit
test_apathize = do
  apathize $ throwError (error "Oh noes!")
  log "Success: Exceptions don't stop the apathetic"

test_putTakeVar :: TestAVar Unit
test_putTakeVar = do
  v <- makeVar
  forkAff (later $ putVar v 1.0)
  a <- takeVar v
  log ("Success: Value " <> show a)

test_peekVar :: TestAVar Unit
test_peekVar = do
  timeout 1000 do
    v <- makeVar
    forkAff (later $ putVar v 1.0)
    a1 <- peekVar v
    a2 <- takeVar v
    when (a1 /= a2) do
      throwError (error "Something horrible went wrong - peeked var is not equal to taken var")
    log ("Success: Peeked value not consumed")

  timeout 1000 do
    w <- makeVar
    putVar w true
    b <- peekVar w
    when (not b) do
      throwError (error "Something horrible went wrong - peeked var is not true")
    log ("Success: Peeked value read from written var")

  timeout 1000 do
    x <- makeVar
    res <- makeVar' 1
    forkAff do
      c <- peekVar x
      putVar x 1000
      d <- peekVar x
      modifyVar (_ + (c + d)) res
    putVar x 10
    count <- takeVar res
    e <- takeVar x
    f <- takeVar x
    when (not (count == 21 && e == 10 && f == 1000)) do
      throwError (error "Something horrible went wrong - peeked consumers/producer ordering")
    log "Success: peekVar consumer/producer order maintained"

test_killFirstForked :: Test Unit
test_killFirstForked = do
  c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
  b <- c `cancel` (error "Just die")
  log (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

test_killVar :: TestAVar Unit
test_killVar = do
  v <- makeVar
  killVar v (error "DOA")
  e <- attempt $ takeVar v
  either (const $ log "Success: Killed queue dead") (const $ log "Failure: Oh noes, queue survived!") e

test_finally :: TestAVar Unit
test_finally = do
  v <- makeVar
  finally
    (putVar v 0)
    (putVar v 2)
  apathize $ finally
    (throwError (error "poof!") *> putVar v 666) -- this putVar should not get executed
    (putVar v 40)
  n1 <- takeVar v
  n2 <- takeVar v
  n3 <- takeVar v
  log $ if n1 + n2 + n3 == 42 then "Success: effects amount to 42."
                                else "Failure: Expected 42."

test_parRace :: TestAVar Unit
test_parRace = do
  s <- sequential (parallel (later' 100 $ pure "Success: Early bird got the worm") <|>
               parallel (later' 200 $ pure "Failure: Late bird got the worm"))
  log s

test_parError :: TestAVar Unit
test_parError = do
  e <- attempt $ sequential (parallel (throwError (error ("Oh noes!"))) *> pure unit)
  either (const $ log "Success: Exception propagated") (const $ log "Failure: Exception missing") e

test_parRaceKill1 :: TestAVar Unit
test_parRaceKill1 = do
  s <- sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
               parallel (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
  log s

test_parRaceKill2 :: TestAVar Unit
test_parRaceKill2 = do
  e <- attempt $ sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
                         parallel (later' 200 $ throwError (error ("Oh noes!"))))
  either (const $ log "Success: Killing both kills it dead") (const $ log "Failure: It's alive!!!") e

test_semigroupCanceler :: Test Unit
test_semigroupCanceler =
  let
    c = Canceler (const (pure true)) <> Canceler (const (pure true))
  in do
    v <- cancel c (error "CANCEL")
    log (if v then "Success: Canceled semigroup composite canceler"
                     else "Failure: Could not cancel semigroup composite canceler")

test_cancelLater :: TestAVar Unit
test_cancelLater = do
  c <- forkAff $ (do pure "Binding"
                     _ <- later' 100 $ log ("Failure: Later was not canceled!")
                     pure "Binding")
  v <- cancel c (error "Cause")
  log (if v then "Success: Canceled later" else "Failure: Did not cancel later")

test_cancelLaunchLater :: forall e. Eff (console :: CONSOLE, err :: EXCEPTION | e) Unit
test_cancelLaunchLater = do
  c <- launchAff $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ launchAff $ (do v <- cancel c (error "Cause")
                         log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelRunLater :: forall e. Eff (console :: CONSOLE | e) Unit
test_cancelRunLater = do
  c <- runAff (const (pure unit)) (const (pure unit)) $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ try $ launchAff $ (do v <- cancel c (error "Cause")
                               log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelParallel :: TestAVar Unit
test_cancelParallel = do
  c  <- forkAff <<< sequential $ parallel (later' 100 $ log "Failure: #1 should not get through") <|>
                             parallel (later' 100 $ log "Failure: #2 should not get through")
  v  <- c `cancel` (error "Must cancel")
  log (if v then "Success: Canceling composite of two Parallel succeeded"
                   else "Failure: Canceling composite of two Parallel failed")

test_syncTailRecM :: TestAVar Unit
test_syncTailRecM = do
  v <- makeVar' false
  _ <- forkAff $ tailRecM go { n: 1000000, v }
  b <- takeVar v
  log (if b then "Success: Synchronous tailRecM resolved synchronously"
            else "Failure: Synchronous tailRecM resolved asynchronously")
  where
  go { n: 0, v } = do
    modifyVar (const true) v
    pure (Done 0)
  go { n, v } = pure (Loop { n: n - 1, v })

loopAndBounce :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
loopAndBounce n = do
  res <- tailRecM go n
  log $ "Done: " <> show res
  where
  go 0 = pure (Done 0)
  go k | mod k 30000 == 0 = do
    later' 10 (pure unit)
    pure (Loop (k - 1))
  go k = pure (Loop (k - 1))

all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
all n = do
  var <- makeVar' 0
  forkAll $ replicateArray n (modifyVar (_ + 1) var)
  count <- takeVar var
  log ("Forked " <> show count)

cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
cancelAll n = do
  canceler <- forkAll $ replicateArray n (later' 100000 (log "oops"))
  canceled <- cancel canceler (error "bye")
  log ("Cancelled all: " <> show canceled)

delay :: forall eff. Int -> Aff eff Unit
delay n = later' n (pure unit)

main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
main = do
  Eff.log "Testing kill of later launched in separate Aff"
  test_cancelLaunchLater

  Eff.log "Testing kill of later run in separate Aff"
  test_cancelRunLater

  void $ runAff throwException (const (pure unit)) $ do
    log "Testing sequencing"
    test_sequencing 3

    log "Testing pure"
    test_pure

    log "Testing makeAff"
    test_makeAff

    log "Testing attempt"
    test_attempt

    log "Testing later"
    later $ log "Success: It happened later"

    log "Testing kill of later"
    test_cancelLater

    log "Testing kill of first forked"
    test_killFirstForked

    log "Testing apathize"
    test_apathize

    log "Testing semigroup canceler"
    test_semigroupCanceler

    log "Testing AVar - putVar, takeVar"
    test_putTakeVar

    log "Testing AVar - peekVar"
    test_peekVar

    log "Testing AVar killVar"
    test_killVar

    log "Testing finally"
    test_finally

    log "Test Parallel (*>)"
    test_parError

    log "Testing Parallel (<|>)"
    test_parRace

    log "Testing Parallel (<|>) - kill one"
    test_parRaceKill1

    log "Testing Parallel (<|>) - kill two"
    test_parRaceKill2

    log "Testing cancel of Parallel (<|>)"
    test_cancelParallel

    log "Testing synchronous tailRecM"
    test_syncTailRecM

    log "pre-delay"
    delay 1000
    log "post-delay"

    loopAndBounce 1000000

    all 100000

    cancelAll 100000

    log "Done testing"

module Test.Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, runAff, makeAff, launchAff, later, later', forkAff, forkAll, Canceler(..), cancel, attempt, finally, apathize)
import Control.Monad.Aff.AVar (AVAR, makeVar, makeVar', putVar, modifyVar, takeVar, peekVar, killVar)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log) as Eff
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error, message, try)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parallel, sequential)
import Data.Either (either, fromLeft, fromRight)
import Data.Unfoldable (replicate)
import Partial.Unsafe (unsafePartial)

type Test a = forall e. Aff (console :: CONSOLE | e) a
type TestAVar a = forall e. Aff (console :: CONSOLE, avar :: AVAR | e) a

replicateArray :: forall a. Int -> a -> Array a
replicateArray = replicate

test_sequencing :: Int -> Test Unit
test_sequencing 0 = log "Done"
test_sequencing n = do
  later' 100 (log (show (n / 10) <> " seconds left"))
  test_sequencing (n - 1)

foreign import synchronousUnexpectedThrowError :: forall e. Eff e Unit

test_makeAff :: Test Unit
test_makeAff = unsafePartial do
  s <- attempt $ makeAff \reject resolve -> resolve "ok"
  log $ "makeAff success is " <> fromRight s

  asyncF <- attempt $ makeAff \reject resolve -> reject (error "ok")
  log $ "makeAff asynchronous failure is " <> message (fromLeft asyncF)

  asyncF' <- attempt $ makeAff \reject resolve -> synchronousUnexpectedThrowError
  log $ "makeAff synchronous failure is " <> message (fromLeft asyncF')

  log "Success: makeAff is ok"

test_pure :: Test Unit
test_pure = do
  pure unit
  pure unit
  pure unit
  log "Success: Got all the way past 4 pures"

test_attempt :: Test Unit
test_attempt = do
  e <- attempt (throwError (error "Oh noes!"))
  either (const $ log "Success: Exception caught") (const $ log "Failure: Exception NOT caught!!!") e

test_apathize :: Test Unit
test_apathize = do
  apathize $ throwError (error "Oh noes!")
  log "Success: Exceptions don't stop the apathetic"

test_putTakeVar :: TestAVar Unit
test_putTakeVar = do
  v <- makeVar
  forkAff (later $ putVar v 1.0)
  a <- takeVar v
  log ("Success: Value " <> show a)

test_peekVar :: TestAVar Unit
test_peekVar = do
  v <- makeVar
  forkAff (later $ putVar v 1.0)
  a1 <- peekVar v
  a2 <- takeVar v
  when (a1 /= a2) do
    throwError (error "Something horrible went wrong - peeked var is not equal to taken var")
  log ("Success: Peeked value not consumed")

  w <- makeVar
  putVar w true
  b <- peekVar w
  when (not b) do
    throwError (error "Something horrible went wrong - peeked var is not true")
  log ("Success: Peeked value read from written var")

  x <- makeVar
  res <- makeVar' 1
  forkAff do
    c <- peekVar x
    putVar x 1000
    d <- peekVar x
    modifyVar (_ + (c + d)) res
  putVar x 10
  count <- takeVar res
  e <- takeVar x
  f <- takeVar x
  when (not (count == 21 && e == 10 && f == 1000)) do
    throwError (error "Something horrible went wrong - peeked consumers/producer ordering")
  log "Success: peekVar consumer/producer order maintained"

test_killFirstForked :: Test Unit
test_killFirstForked = do
  c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
  b <- c `cancel` (error "Just die")
  log (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

test_killVar :: TestAVar Unit
test_killVar = do
  v <- makeVar
  killVar v (error "DOA")
  e <- attempt $ takeVar v
  either (const $ log "Success: Killed queue dead") (const $ log "Failure: Oh noes, queue survived!") e

test_finally :: TestAVar Unit
test_finally = do
  v <- makeVar
  finally
    (putVar v 0)
    (putVar v 2)
  apathize $ finally
    (throwError (error "poof!") *> putVar v 666) -- this putVar should not get executed
    (putVar v 40)
  n1 <- takeVar v
  n2 <- takeVar v
  n3 <- takeVar v
  log $ if n1 + n2 + n3 == 42 then "Success: effects amount to 42."
                                else "Failure: Expected 42."

test_parRace :: TestAVar Unit
test_parRace = do
  s <- sequential (parallel (later' 100 $ pure "Success: Early bird got the worm") <|>
               parallel (later' 200 $ pure "Failure: Late bird got the worm"))
  log s

test_parError :: TestAVar Unit
test_parError = do
  e <- attempt $ sequential (parallel (throwError (error ("Oh noes!"))) *> pure unit)
  either (const $ log "Success: Exception propagated") (const $ log "Failure: Exception missing") e

test_parRaceKill1 :: TestAVar Unit
test_parRaceKill1 = do
  s <- sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
               parallel (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
  log s

test_parRaceKill2 :: TestAVar Unit
test_parRaceKill2 = do
  e <- attempt $ sequential (parallel (later' 100 $ throwError (error ("Oh noes!"))) <|>
                         parallel (later' 200 $ throwError (error ("Oh noes!"))))
  either (const $ log "Success: Killing both kills it dead") (const $ log "Failure: It's alive!!!") e

test_semigroupCanceler :: Test Unit
test_semigroupCanceler =
  let
    c = Canceler (const (pure true)) <> Canceler (const (pure true))
  in do
    v <- cancel c (error "CANCEL")
    log (if v then "Success: Canceled semigroup composite canceler"
                     else "Failure: Could not cancel semigroup composite canceler")

test_cancelLater :: TestAVar Unit
test_cancelLater = do
  c <- forkAff $ (do pure "Binding"
                     _ <- later' 100 $ log ("Failure: Later was not canceled!")
                     pure "Binding")
  v <- cancel c (error "Cause")
  log (if v then "Success: Canceled later" else "Failure: Did not cancel later")

test_cancelLaunchLater :: forall e. Eff (console :: CONSOLE, err :: EXCEPTION | e) Unit
test_cancelLaunchLater = do
  c <- launchAff $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ launchAff $ (do v <- cancel c (error "Cause")
                         log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelRunLater :: forall e. Eff (console :: CONSOLE | e) Unit
test_cancelRunLater = do
  c <- runAff (const (pure unit)) (const (pure unit)) $ later' 100 $ log ("Failure: Later was not canceled!")
  void $ try $ launchAff $ (do v <- cancel c (error "Cause")
                               log (if v then "Success: Canceled later" else "Failure: Did not cancel later"))

test_cancelParallel :: TestAVar Unit
test_cancelParallel = do
  c  <- forkAff <<< sequential $ parallel (later' 100 $ log "Failure: #1 should not get through") <|>
                             parallel (later' 100 $ log "Failure: #2 should not get through")
  v  <- c `cancel` (error "Must cancel")
  log (if v then "Success: Canceling composite of two Parallel succeeded"
                   else "Failure: Canceling composite of two Parallel failed")

test_syncTailRecM :: TestAVar Unit
test_syncTailRecM = do
  v <- makeVar' false
  _ <- forkAff $ tailRecM go { n: 1000000, v }
  b <- takeVar v
  log (if b then "Success: Synchronous tailRecM resolved synchronously"
            else "Failure: Synchronous tailRecM resolved asynchronously")
  where
  go { n: 0, v } = do
    modifyVar (const true) v
    pure (Done 0)
  go { n, v } = pure (Loop { n: n - 1, v })

loopAndBounce :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
loopAndBounce n = do
  res <- tailRecM go n
  log $ "Done: " <> show res
  where
  go 0 = pure (Done 0)
  go k | mod k 30000 == 0 = do
    later' 10 (pure unit)
    pure (Loop (k - 1))
  go k = pure (Loop (k - 1))

all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
all n = do
  var <- makeVar' 0
  forkAll $ replicateArray n (modifyVar (_ + 1) var)
  count <- takeVar var
  log ("Forked " <> show count)

cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
cancelAll n = do
  canceler <- forkAll $ replicateArray n (later' 100000 (log "oops"))
  canceled <- cancel canceler (error "bye")
  log ("Cancelled all: " <> show canceled)

delay :: forall eff. Int -> Aff eff Unit
delay n = later' n (pure unit)

main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
main = do
  Eff.log "Testing kill of later launched in separate Aff"
  test_cancelLaunchLater

  Eff.log "Testing kill of later run in separate Aff"
  test_cancelRunLater

  void $ runAff throwException (const (pure unit)) $ do
    log "Testing sequencing"
    test_sequencing 3

    log "Testing pure"
    test_pure

    log "Testing makeAff"
    test_makeAff

    log "Testing attempt"
    test_attempt

    log "Testing later"
    later $ log "Success: It happened later"

    log "Testing kill of later"
    test_cancelLater

    log "Testing kill of first forked"
    test_killFirstForked

    log "Testing apathize"
    test_apathize

    log "Testing semigroup canceler"
    test_semigroupCanceler

    log "Testing AVar - putVar, takeVar"
    test_putTakeVar

    log "Testing AVar - peekVar"
    test_peekVar

    log "Testing AVar killVar"
    test_killVar

    log "Testing finally"
    test_finally

    log "Test Parallel (*>)"
    test_parError

    log "Testing Parallel (<|>)"
    test_parRace

    log "Testing Parallel (<|>) - kill one"
    test_parRaceKill1

    log "Testing Parallel (<|>) - kill two"
    test_parRaceKill2

    log "Testing cancel of Parallel (<|>)"
    test_cancelParallel

    log "Testing synchronous tailRecM"
    test_syncTailRecM

    log "pre-delay"
    delay 1000
    log "post-delay"

    loopAndBounce 1000000

    all 100000

    cancelAll 100000

    log "Done testing"


Added a type signatue to main.

Added a type signatue to main.

module GenericDeriving where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (CONSOLE())
import Data.Generic

data Void

derive instance genericVoid :: Generic Void

data A a
  = A Number String
  | B Int
  | C (Array (A a))
  | D { a :: a }
  | E Void

derive instance genericA :: (Generic a) => Generic (A a)

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))

module GenericDeriving where

import Prelude

import Data.Generic

data Void

derive instance genericVoid :: Generic Void

data A a
  = A Number String
  | B Int
  | C (Array (A a))
  | D { a :: a }
  | E Void

derive instance genericA :: (Generic a) => Generic (A a)

main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))