[CSE-116] Extend table layout of block txs

module Explorer.View.Block (blockView) where

import Prelude
import Data.Array (length, null, slice, (..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Test.MockFactory (mkTxBriefs)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..), isFailure)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)
import Pux.Html (Html, div, text, h3, span) as P
import Pux.Html.Attributes (className) as P
import Pux.Router (link) as P

blockView :: State -> P.Html Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    P.div
        [ P.className "explorer-block" ]
        [ P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                  [ P.className "explorer-block__container" ]
                  [ P.h3
                        [ P.className "headline"]
                        [ P.text $ translate (I18nL.common <<< I18nL.cBlock) lang' ]
                    , case blockSummary of
                          NotAsked -> blockSummaryEmptyView ""
                          Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                          Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                          Success block -> blockSummaryView block lang'
                  ]

            ]
        , P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                [ P.className "explorer-block__container" ]
                [ P.h3
                      [ P.className "headline"]
                      [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang' ]
                , case blockTxs of
                      NotAsked -> txEmptyContentView ""
                      Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                      -- Success txs -> blockTxsView txs state
                      -- TODO (jk): Use real data
                      Success txs -> blockTxsView (mkTxBriefs (1..12)) state
                ]
            , if (isFailure blockSummary && isFailure blockTxs)
              -- Show back button if both results ^ are failed
              then
                  P.div
                      [ P.className "explorer-block__container" ]
                      [ P.link (toUrl Dashboard)
                          [ P.className "btn-back" ]
                          [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang' ]
                      ]
              else
                  emptyView
            ]
        ]

--  summary

type SummaryRowItem =
    { label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blEstVolume) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.Html Action
summaryRow item =
    P.div
        [ P.className "row row__summary" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "column column__amount" ]
              if isJust item.mCurrency
              then
                  [ P.span
                        [ P.className $ currencyCSSClass item.mCurrency ]
                        [ P.text item.amount ]
                  ]
              else
                  [ P.text item.amount ]
        ]

blockSummaryEmptyView :: String -> P.Html Action
blockSummaryEmptyView message =
    P.div
        [ P.className "summary-empty__container" ]
        [P.text message ]

blockSummaryView :: CBlockSummary -> Language -> P.Html Action
blockSummaryView block lang =
    P.div
      [ P.className "blocks-wrapper" ]
      [ P.div
        -- summary
        [ P.className "summary-container" ]
        [ P.h3
          [ P.className "subheadline" ]
          [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang ]
        , P.div
            []
            <<< map summaryRow <<< mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)
        ]-- hashes
      , P.div
        [ P.className "hashes-container" ]
        [ P.h3
            [ P.className "subheadline" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cHashes) lang ]
        , P.div
            []
            <<< map hashesRow $ mkHashItems lang block
        ]
  ]

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.Html Action
hashesRow item =
    P.div
        [ P.className "row row__hashes" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , case item.link of
              Nothing ->  P.div
                              [ P.className $ "column column__hash" ]
                              [ P.text item.hash ]
              Just link -> P.link link
                              [ P.className $ "column column__hash--link" ]
                              [ P.text item.hash ]
        ]

maxTxRows :: Int
maxTxRows = 5

blockTxsView :: CTxBriefs -> State -> P.Html Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            lang' = state ^. lang
            minTxIndex = (txPagination - minPagination) * maxTxRows
            currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
        in
        P.div
            []
            [ P.div
                  []
                  $ map (\tx -> blockTxView tx lang') currentTxs
            , txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                , currentPage: PageNumber txPagination
                                , minPage: PageNumber minPagination
                                , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                                , changePageAction: BlockPaginateTxs
                                , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                                , editableAction: BlockEditTxsPageNumber
                                , invalidPageAction: BlockInvalidTxsPageNumber
                                , disabled: false
                                }
            ]

blockTxView :: CTxBrief -> Language -> P.Html Action
blockTxView tx lang =
    P.div
        []
        [ txHeaderView lang $ mkTxHeaderViewProps tx
        , txBodyView lang $ mkTxBodyViewProps tx
        ]

module Explorer.View.Block (blockView) where

import Prelude
import Data.Array (length, null, (!!))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, mkEmptyViewProps, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..), isFailure)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)
import Pux.Html (Html, div, text, h3, span) as P
import Pux.Html.Attributes (className) as P
import Pux.Router (link) as P

blockView :: State -> P.Html Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    P.div
        [ P.className "explorer-block" ]
        [ P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                  [ P.className "explorer-block__container" ]
                  [ P.h3
                        [ P.className "headline"]
                        [ P.text $ translate (I18nL.common <<< I18nL.cBlock) lang' ]
                    , case blockSummary of
                          NotAsked -> blockSummaryEmptyView ""
                          Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                          Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                          Success block -> blockSummaryView block lang'
                  ]

            ]
        , P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                [ P.className "explorer-block__container" ]
                [ P.h3
                      [ P.className "headline"]
                      [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang' ]
                , case blockTxs of
                      NotAsked -> txEmptyContentView ""
                      Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                      Success txs -> blockTxsView txs state
                ]
            , if (isFailure blockSummary && isFailure blockTxs)
              -- Show back button if both results ^ are failed
              then
                  P.div
                      [ P.className "explorer-block__container" ]
                      [ P.link (toUrl Dashboard)
                          [ P.className "btn-back" ]
                          [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang' ]
                      ]
              else
                  emptyView
            ]
        ]

--  summary

type SummaryRowItem =
    { label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blEstVolume) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.Html Action
summaryRow item =
    P.div
        [ P.className "row row__summary" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "column column__amount" ]
              if isJust item.mCurrency
              then
                  [ P.span
                        [ P.className $ currencyCSSClass item.mCurrency ]
                        [ P.text item.amount ]
                  ]
              else
                  [ P.text item.amount ]
        ]

blockSummaryEmptyView :: String -> P.Html Action
blockSummaryEmptyView message =
    P.div
        [ P.className "summary-empty__container" ]
        [P.text message ]

blockSummaryView :: CBlockSummary -> Language -> P.Html Action
blockSummaryView block lang =
    P.div
      [ P.className "blocks-wrapper" ]
      [ P.div
        -- summary
        [ P.className "summary-container" ]
        [ P.h3
          [ P.className "subheadline" ]
          [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang ]
        , P.div
            []
            <<< map summaryRow <<< mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)
        ]-- hashes
      , P.div
        [ P.className "hashes-container" ]
        [ P.h3
            [ P.className "subheadline" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cHashes) lang ]
        , P.div
            []
            <<< map hashesRow $ mkHashItems lang block
        ]
  ]

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.Html Action
hashesRow item =
    P.div
        [ P.className "row row__hashes" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , case item.link of
              Nothing ->  P.div
                              [ P.className $ "column column__hash" ]
                              [ P.text item.hash ]
              Just link -> P.link link
                              [ P.className $ "column column__hash--link" ]
                              [ P.text item.hash ]
        ]

blockTxsView :: CTxBriefs -> State -> P.Html Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            currentTxBrief = txs !! (txPagination - 1)
            txBodyViewProps = fromMaybe (mkTxBodyViewProps mkEmptyViewProps) $ mkTxBodyViewProps <$> currentTxBrief
            lang' = state ^. lang
        in
        P.div
            []
            [ txHeaderView lang' $ case currentTxBrief of
                                        Nothing -> mkTxHeaderViewProps mkEmptyViewProps
                                        Just txBrief -> mkTxHeaderViewProps txBrief
            , txBodyView lang' txBodyViewProps
            , txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                , currentPage: PageNumber txPagination
                                , minPage: PageNumber minPagination
                                , maxPage: PageNumber $ length txs
                                , changePageAction: BlockPaginateTxs
                                , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                                , editableAction: BlockEditTxsPageNumber
                                , invalidPageAction: BlockInvalidTxsPageNumber
                                , disabled: false
                                }
            ]


[CSE-116] Remove mock data to use real data

module Explorer.View.Block (blockView) where

import Prelude
import Data.Array (length, null, slice)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..), isFailure)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)
import Pux.Html (Html, div, text, h3, span) as P
import Pux.Html.Attributes (className) as P
import Pux.Router (link) as P

blockView :: State -> P.Html Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    P.div
        [ P.className "explorer-block" ]
        [ P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                  [ P.className "explorer-block__container" ]
                  [ P.h3
                        [ P.className "headline"]
                        [ P.text $ translate (I18nL.common <<< I18nL.cBlock) lang' ]
                    , case blockSummary of
                          NotAsked -> blockSummaryEmptyView ""
                          Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                          Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                          Success block -> blockSummaryView block lang'
                  ]

            ]
        , P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                [ P.className "explorer-block__container" ]
                [ P.h3
                      [ P.className "headline"]
                      [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang' ]
                , case blockTxs of
                      NotAsked -> txEmptyContentView ""
                      Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                      Success txs -> blockTxsView txs state
                ]
            , if (isFailure blockSummary && isFailure blockTxs)
              -- Show back button if both results ^ are failed
              then
                  P.div
                      [ P.className "explorer-block__container" ]
                      [ P.link (toUrl Dashboard)
                          [ P.className "btn-back" ]
                          [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang' ]
                      ]
              else
                  emptyView
            ]
        ]

--  summary

type SummaryRowItem =
    { label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blEstVolume) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.Html Action
summaryRow item =
    P.div
        [ P.className "row row__summary" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "column column__amount" ]
              if isJust item.mCurrency
              then
                  [ P.span
                        [ P.className $ currencyCSSClass item.mCurrency ]
                        [ P.text item.amount ]
                  ]
              else
                  [ P.text item.amount ]
        ]

blockSummaryEmptyView :: String -> P.Html Action
blockSummaryEmptyView message =
    P.div
        [ P.className "summary-empty__container" ]
        [P.text message ]

blockSummaryView :: CBlockSummary -> Language -> P.Html Action
blockSummaryView block lang =
    P.div
      [ P.className "blocks-wrapper" ]
      [ P.div
        -- summary
        [ P.className "summary-container" ]
        [ P.h3
          [ P.className "subheadline" ]
          [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang ]
        , P.div
            []
            <<< map summaryRow <<< mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)
        ]-- hashes
      , P.div
        [ P.className "hashes-container" ]
        [ P.h3
            [ P.className "subheadline" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cHashes) lang ]
        , P.div
            []
            <<< map hashesRow $ mkHashItems lang block
        ]
  ]

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.Html Action
hashesRow item =
    P.div
        [ P.className "row row__hashes" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , case item.link of
              Nothing ->  P.div
                              [ P.className $ "column column__hash" ]
                              [ P.text item.hash ]
              Just link -> P.link link
                              [ P.className $ "column column__hash--link" ]
                              [ P.text item.hash ]
        ]

maxTxRows :: Int
maxTxRows = 5

blockTxsView :: CTxBriefs -> State -> P.Html Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            lang' = state ^. lang
            minTxIndex = (txPagination - minPagination) * maxTxRows
            currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
        in
        P.div
            []
            [ P.div
                  []
                  $ map (\tx -> blockTxView tx lang') currentTxs
            , txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                , currentPage: PageNumber txPagination
                                , minPage: PageNumber minPagination
                                , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                                , changePageAction: BlockPaginateTxs
                                , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                                , editableAction: BlockEditTxsPageNumber
                                , invalidPageAction: BlockInvalidTxsPageNumber
                                , disabled: false
                                }
            ]

blockTxView :: CTxBrief -> Language -> P.Html Action
blockTxView tx lang =
    P.div
        []
        [ txHeaderView lang $ mkTxHeaderViewProps tx
        , txBodyView lang $ mkTxBodyViewProps tx
        ]

module Explorer.View.Block (blockView) where

import Prelude
import Data.Array (length, null, slice, (..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Test.MockFactory (mkTxBriefs)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..), isFailure)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)
import Pux.Html (Html, div, text, h3, span) as P
import Pux.Html.Attributes (className) as P
import Pux.Router (link) as P

blockView :: State -> P.Html Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    P.div
        [ P.className "explorer-block" ]
        [ P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                  [ P.className "explorer-block__container" ]
                  [ P.h3
                        [ P.className "headline"]
                        [ P.text $ translate (I18nL.common <<< I18nL.cBlock) lang' ]
                    , case blockSummary of
                          NotAsked -> blockSummaryEmptyView ""
                          Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                          Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                          Success block -> blockSummaryView block lang'
                  ]

            ]
        , P.div
            [ P.className "explorer-block__wrapper" ]
            [ P.div
                [ P.className "explorer-block__container" ]
                [ P.h3
                      [ P.className "headline"]
                      [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang' ]
                , case blockTxs of
                      NotAsked -> txEmptyContentView ""
                      Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                      -- Success txs -> blockTxsView txs state
                      -- TODO (jk): Use real data
                      Success txs -> blockTxsView (mkTxBriefs (1..12)) state
                ]
            , if (isFailure blockSummary && isFailure blockTxs)
              -- Show back button if both results ^ are failed
              then
                  P.div
                      [ P.className "explorer-block__container" ]
                      [ P.link (toUrl Dashboard)
                          [ P.className "btn-back" ]
                          [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang' ]
                      ]
              else
                  emptyView
            ]
        ]

--  summary

type SummaryRowItem =
    { label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blEstVolume) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.Html Action
summaryRow item =
    P.div
        [ P.className "row row__summary" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "column column__amount" ]
              if isJust item.mCurrency
              then
                  [ P.span
                        [ P.className $ currencyCSSClass item.mCurrency ]
                        [ P.text item.amount ]
                  ]
              else
                  [ P.text item.amount ]
        ]

blockSummaryEmptyView :: String -> P.Html Action
blockSummaryEmptyView message =
    P.div
        [ P.className "summary-empty__container" ]
        [P.text message ]

blockSummaryView :: CBlockSummary -> Language -> P.Html Action
blockSummaryView block lang =
    P.div
      [ P.className "blocks-wrapper" ]
      [ P.div
        -- summary
        [ P.className "summary-container" ]
        [ P.h3
          [ P.className "subheadline" ]
          [ P.text $ translate (I18nL.common <<< I18nL.cSummary) lang ]
        , P.div
            []
            <<< map summaryRow <<< mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)
        ]-- hashes
      , P.div
        [ P.className "hashes-container" ]
        [ P.h3
            [ P.className "subheadline" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cHashes) lang ]
        , P.div
            []
            <<< map hashesRow $ mkHashItems lang block
        ]
  ]

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.Html Action
hashesRow item =
    P.div
        [ P.className "row row__hashes" ]
        [ P.div
            [ P.className "column column__label" ]
            [ P.text item.label ]
        , case item.link of
              Nothing ->  P.div
                              [ P.className $ "column column__hash" ]
                              [ P.text item.hash ]
              Just link -> P.link link
                              [ P.className $ "column column__hash--link" ]
                              [ P.text item.hash ]
        ]

maxTxRows :: Int
maxTxRows = 5

blockTxsView :: CTxBriefs -> State -> P.Html Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            lang' = state ^. lang
            minTxIndex = (txPagination - minPagination) * maxTxRows
            currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
        in
        P.div
            []
            [ P.div
                  []
                  $ map (\tx -> blockTxView tx lang') currentTxs
            , txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                , currentPage: PageNumber txPagination
                                , minPage: PageNumber minPagination
                                , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                                , changePageAction: BlockPaginateTxs
                                , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                                , editableAction: BlockEditTxsPageNumber
                                , invalidPageAction: BlockInvalidTxsPageNumber
                                , disabled: false
                                }
            ]

blockTxView :: CTxBrief -> Language -> P.Html Action
blockTxView tx lang =
    P.div
        []
        [ txHeaderView lang $ mkTxHeaderViewProps tx
        , txBodyView lang $ mkTxBodyViewProps tx
        ]


Add LOD to the pivot table builder

Add LOD to the pivot table builder

{-
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.Card.BuildChart.PivotTable.Component where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Array as Array
import Data.Int (toNumber)

import CSS as C
import Halogen as H
import Halogen.Component.Utils.Drag as Drag
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.HTML.CSS.Indexed as HC

import SlamData.Form.Select as S
import SlamData.Monad (Slam)
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.DimensionPicker.Component as DPC
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.ChildSlot as PCS
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.Query (Query(..), QueryC)
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.State (State, Selecting(..), modelFromState, stateFromModel, initialState, reorder, setColumnAggregation)
import SlamData.Workspace.Card.BuildChart.PivotTable.Model (Column(..))
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType as CHT
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type DSL = H.ParentDSL State PCS.ChildState QueryC PCS.ChildQuery Slam PCS.ChildSlot

type HTML = H.ParentHTML PCS.ChildState QueryC PCS.ChildQuery Slam PCS.ChildSlot

pivotTableBuilderComponent ∷ CC.CardComponent
pivotTableBuilderComponent = CC.makeCardComponent
  { cardType: CT.ChartOptions CHT.PivotTable
  , component: H.parentComponent
      { render
      , eval: coproduct evalCard evalOptions
      , peek: Just peek
      }
  , initialState: H.parentState initialState
  , _State: CC._BuildPivotTableState
  , _Query: CC.makeQueryPrism' CC._BuildPivotTableQuery
  }

render ∷ State → HTML
render st =
  if st.levelOfDetails ≡ High
    then renderHighLOD st
    else renderLowLOD (CT.darkCardGlyph (CT.ChartOptions CHT.PivotTable)) left st.levelOfDetails

renderHighLOD ∷ State → HTML
renderHighLOD st =
  HH.div
    [ HP.classes [ HH.className "sd-pivot-options" ] ]
    [ HH.div
        [ HP.classes [ HH.className "sd-pivot-options-corner" ] ]
        [ HH.span_ [ HH.text "Dimensions" ]
        , HH.span_ [ HH.text "Columns" ]
        ]
    , HH.div
        [ HP.classes [ HH.className "sd-pivot-options-dims" ] ]
        renderedDimensions
    , HH.div
        [ HP.classes [ HH.className "sd-pivot-options-cols" ] ]
        renderedColumns
    , maybe (HH.text "") renderSelect st.selecting
    ]
  where
  renderSelect = case _ of
    Col →
      let
        values =
          Array.cons Count
            (map (Column ∘ { value: _, valueAggregation: Nothing })
              (Array.sort (st.axes.category <> st.axes.time <> st.axes.value)))
      in
        HH.slot' PCS.cpCol unit \_ →
          { component: DPC.picker "Choose column" showColumn
          , initialState: { values, selectedIndex: -1 }
          }
    Dim →
      let
        values =
          Array.sort (st.axes.category <> st.axes.time <> st.axes.value)
      in
        HH.slot' PCS.cpDim unit \_ →
          { component: DPC.picker "Choose dimension" showJCursor
          , initialState: { values, selectedIndex: -1 }
          }

  renderedDimensions =
    let
      len  = Array.length st.dimensions + 1
      size = 100.0 / toNumber len
    in
      map (renderDimension size) st.dimensions <>
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-dim" ]
          , HC.style (C.height (C.pct size))
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-dim-inner"] ]
              [ HH.button
                  [ HP.classes [ HH.className "sd-pivot-options-plus" ]
                  , HE.onClick (HE.input_ (right ∘ AddDimension))
                  ]
                  []
              ]
          ]
      ]

  renderDimension size (slot × dim) =
    HH.div
      ([ HP.classes (dimensionClasses slot)
       , HC.style (C.height (C.pct size))
       ] <> dimensionEvents slot)
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-dim-inner"]
          , HC.style (dimensionStyles slot size)
          ]
          [ HH.button
              [ HP.classes [ HH.className "sd-pivot-options-label" ]
              , HE.onMouseDown (HE.input (\e → right ∘ OrderDimensionStart slot e))
              ]
              [ HH.text (showJCursor dim) ]
          , HH.button
              [ HP.classes [ HH.className "sd-dismiss-button" ]
              , HP.title "Delete dimension"
              , ARIA.label "Delete dimension"
              , HE.onClick (HE.input_ (right ∘ RemoveDimension slot))
              ]
              [ HH.text "×"]
          ]
      ]

  dimensionClasses slot =
    [ HH.className "sd-pivot-options-dim" ] <>
      case st.orderingDimension of
        Just opts | opts.source == slot → [ HH.className "ordering" ]
        Just opts | opts.over == Just slot → [ HH.className "ordering-over" ]
        _ → []

  dimensionStyles slot size = do
    case st.orderingDimension of
      Just opts | opts.source == slot → C.top (C.px opts.offset)
      _ → pure unit

  dimensionEvents slot =
    if isJust st.orderingDimension
      then
        [ HE.onMouseOver (HE.input_ (right ∘ OrderOverDimension slot))
        , HE.onMouseOut (HE.input_ (right ∘ OrderOutDimension slot))
        ]
      else
        []

  renderedColumns =
    let
      len  = Array.length st.columns + 1
      size = 100.0 / toNumber len
    in
      map (renderColumn size) st.columns <>
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-col" ]
          , HC.style (C.width (C.pct size))
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-inner"] ]
              [ HH.div
                  [ HP.classes [ HH.className "sd-pivot-options-col-value" ] ]
                  [ HH.button
                      [ HP.classes [ HH.className "sd-pivot-options-plus" ]
                      , HE.onClick (HE.input_ (right ∘ AddColumn))
                      ]
                      []
                  ]
              , HH.div
                  [ HP.classes [ HH.className "sd-pivot-options-col-aggregation" ] ]
                  []
              ]
          ]
      ]

  renderColumn size (slot × col) =
    HH.div
      ([ HP.classes (columnClasses slot)
       , HC.style (C.width (C.pct size))
       ] <> columnEvents slot)
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-col-inner"]
          , HC.style (columnStyles slot size)
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-value" ] ]
              [ HH.button
                  [ HP.classes [ HH.className "sd-pivot-options-label" ]
                  , HE.onMouseDown (HE.input (\e → right ∘ OrderColumnStart slot e))
                  ]
                  [ HH.text (showColumn col)
                  ]
              , HH.button
                  [ HP.classes [ HH.className "sd-dismiss-button" ]
                  , HP.title "Delete column"
                  , ARIA.label "Delete column"
                  , HE.onClick (HE.input_ (right ∘ RemoveColumn slot))
                  ]
                  [ HH.text "×"]
              ]
          , HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-aggregation" ] ]
              case col of
                Column { valueAggregation } → [ columnSelect slot valueAggregation ]
                _ → []
          ]
      ]

  columnClasses slot =
    [ HH.className "sd-pivot-options-col" ] <>
      case st.orderingColumn of
        Just opts | opts.source == slot → [ HH.className "ordering" ]
        Just opts | opts.over == Just slot → [ HH.className "ordering-over" ]
        _ → []

  columnStyles slot size = do
    case st.orderingColumn of
      Just opts | opts.source == slot → C.left (C.px opts.offset)
      _ → pure unit

  columnEvents slot =
    if isJust st.orderingColumn
      then
        [ HE.onMouseOver (HE.input_ (right ∘ OrderOverColumn slot))
        , HE.onMouseOut (HE.input_ (right ∘ OrderOutColumn slot))
        ]
      else
        []

  columnSelect slot ag =
    HH.div
      [ HP.classes [ HH.className "list-group" ] ]
      (map (selectBtn slot ag)
        [ Nothing
        , Just Ag.Maximum
        , Just Ag.Minimum
        , Just Ag.Average
        , Just Ag.Sum
        -- Not supported by the backend
        -- , Just Ag.Product
        ])

  selectBtn slot ag ctr =
    HH.button
      [ HP.classes
          ([ HH.className "list-group-item" ]
           <> (HH.className "active" <$ guard (ctr == ag)))
      , HE.onClick (HE.input_ (right ∘ ChooseAggregation slot ctr))
      ]
      [ HH.text (maybe "Tabulate" S.stringVal ctr) ]

  showColumn (Column { value }) = showJCursor value
  showColumn Count = "COUNT"

  showJCursor (J.JField i c) = i <> show c
  showJCursor c = show c

evalCard ∷ CC.CardEvalQuery ~> DSL
evalCard = case _ of
  CC.EvalCard info _ next → do
    case info.input of
      Just (Port.TaggedResource { axes }) →
        H.modify _ { axes = axes }
      _ → pure unit
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.SetDimensions dims next → do
    H.modify _
      { levelOfDetails =
          if dims.width < 540.0 || dims.height < 360.0
            then Low
            else High
      }
    pure next
  CC.Save k →
    map (k ∘ Card.BuildPivotTable ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.BuildPivotTable model →
        H.modify (stateFromModel model)
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalOptions ∷ Query ~> DSL
evalOptions = case _ of
  AddDimension next → do
    H.modify _ { selecting = Just Dim }
    pure next
  AddColumn next → do
    H.modify _ { selecting = Just Col }
    pure next
  RemoveDimension slot next → do
    H.modify \st →
      st { dimensions = Array.filter (not ∘ eq slot ∘ fst) st.dimensions }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  RemoveColumn slot next → do
    H.modify \st →
      st { columns = Array.filter (not ∘ eq slot ∘ fst) st.columns }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  OrderDimensionStart slot ev next → do
    let
      opts =
        { source: slot
        , over: Nothing
        , offset: 0.0
        }
    Drag.subscribe' ev (right ∘ H.action ∘ OrderingDimension slot)
    H.modify _ { orderingDimension = Just opts }
    pure next
  OrderingDimension slot ev next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      case ev of
        Drag.Move _ d →
          H.modify _ { orderingDimension = Just opts { offset = d.offsetY } }
        Drag.Done _ →
          case opts.over of
            Just slot' → do
              H.modify _
                { orderingDimension = Nothing
                , dimensions = reorder slot slot' st.dimensions
                }
              CC.raiseUpdatedP' CC.EvalModelUpdate
            Nothing →
              H.modify _ { orderingDimension = Nothing }
    pure next
  OrderOverDimension slot next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      H.modify _ { orderingDimension = Just (opts { over = Just slot }) }
    pure next
  OrderOutDimension slot next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      H.modify _ { orderingDimension = Just (opts { over = Nothing }) }
    pure next
  OrderColumnStart slot ev next → do
    let
      opts =
        { source: slot
        , over: Nothing
        , offset: 0.0
        }
    Drag.subscribe' ev (right ∘ H.action ∘ OrderingColumn slot)
    H.modify _ { orderingColumn = Just opts }
    pure next
  OrderingColumn slot ev next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      case ev of
        Drag.Move _ d →
          H.modify _ { orderingColumn = Just opts { offset = d.offsetX } }
        Drag.Done _ →
          case opts.over of
            Just slot' → do
              H.modify _
                { orderingColumn = Nothing
                , columns = reorder slot slot' st.columns
                }
              CC.raiseUpdatedP' CC.EvalModelUpdate
            Nothing →
              H.modify _ { orderingColumn = Nothing }
    pure next
  OrderOverColumn slot next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      H.modify _ { orderingColumn = Just (opts { over = Just slot }) }
    pure next
  OrderOutColumn slot next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      H.modify _ { orderingColumn = Just (opts { over = Nothing }) }
    pure next
  ChooseAggregation slot ag next → do
    st ← H.get
    H.modify (setColumnAggregation slot ag)
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next

peek ∷ ∀ a. H.ChildF PCS.ChildSlot PCS.ChildQuery a → DSL Unit
peek = (coproduct peekSelectDim peekSelectCol) ∘ H.runChildF
  where
  peekSelectDim = case _ of
    DPC.Dismiss _ →
      H.modify _ { selecting = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      H.modify _
        { fresh = st.fresh + 1
        , dimensions = Array.snoc st.dimensions (st.fresh × value)
        , selecting = Nothing
        }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ →
      pure unit

  peekSelectCol = case _ of
    DPC.Dismiss _ →
      H.modify _ { selecting = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      H.modify _
        { fresh = st.fresh + 1
        , columns = Array.snoc st.columns (st.fresh × value)
        , selecting = Nothing
        }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ →
      pure unit

{-
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.Card.BuildChart.PivotTable.Component where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Array as Array
import Data.Int (toNumber)

import CSS as C
import Halogen as H
import Halogen.Component.Utils.Drag as Drag
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.HTML.CSS.Indexed as HC

import SlamData.Form.Select as S
import SlamData.Monad (Slam)
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.DimensionPicker.Component as DPC
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.ChildSlot as PCS
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.Query (Query(..), QueryC)
import SlamData.Workspace.Card.BuildChart.PivotTable.Component.State (State, Selecting(..), modelFromState, stateFromModel, initialState, reorder, setColumnAggregation)
import SlamData.Workspace.Card.BuildChart.PivotTable.Model (Column(..))
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType as CHT
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type DSL = H.ParentDSL State PCS.ChildState QueryC PCS.ChildQuery Slam PCS.ChildSlot

type HTML = H.ParentHTML PCS.ChildState QueryC PCS.ChildQuery Slam PCS.ChildSlot

pivotTableBuilderComponent ∷ CC.CardComponent
pivotTableBuilderComponent = CC.makeCardComponent
  { cardType: CT.ChartOptions CHT.PivotTable
  , component: H.parentComponent
      { render
      , eval: coproduct evalCard evalOptions
      , peek: Just peek
      }
  , initialState: H.parentState initialState
  , _State: CC._BuildPivotTableState
  , _Query: CC.makeQueryPrism' CC._BuildPivotTableQuery
  }

render ∷ State → HTML
render st =
  if st.levelOfDetails ≡ High
    then renderHighLOD st
    else renderLowLOD (CT.darkCardGlyph (CT.ChartOptions CHT.PivotTable)) left st.levelOfDetails

renderHighLOD ∷ State → HTML
renderHighLOD st =
  HH.div
    [ HP.classes [ HH.className "sd-pivot-options" ] ]
    [ HH.div
        [ HP.classes [ HH.className "sd-pivot-options-corner" ] ]
        [ HH.span_ [ HH.text "Dimensions" ]
        , HH.span_ [ HH.text "Columns" ]
        ]
    , HH.div
        [ HP.classes [ HH.className "sd-pivot-options-dims" ] ]
        renderedDimensions
    , HH.div
        [ HP.classes [ HH.className "sd-pivot-options-cols" ] ]
        renderedColumns
    , maybe (HH.text "") renderSelect st.selecting
    ]
  where
  renderSelect = case _ of
    Col →
      let
        values =
          Array.cons Count
            (map (Column ∘ { value: _, valueAggregation: Nothing })
              (Array.sort (st.axes.category <> st.axes.time <> st.axes.value)))
      in
        HH.slot' PCS.cpCol unit \_ →
          { component: DPC.picker "Choose column" showColumn
          , initialState: { values, selectedIndex: -1 }
          }
    Dim →
      let
        values =
          Array.sort (st.axes.category <> st.axes.time <> st.axes.value)
      in
        HH.slot' PCS.cpDim unit \_ →
          { component: DPC.picker "Choose dimension" showJCursor
          , initialState: { values, selectedIndex: -1 }
          }

  renderedDimensions =
    let
      len  = Array.length st.dimensions + 1
      size = 100.0 / toNumber len
    in
      map (renderDimension size) st.dimensions <>
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-dim" ]
          , HC.style (C.height (C.pct size))
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-dim-inner"] ]
              [ HH.button
                  [ HP.classes [ HH.className "sd-pivot-options-plus" ]
                  , HE.onClick (HE.input_ (right ∘ AddDimension))
                  ]
                  []
              ]
          ]
      ]

  renderDimension size (slot × dim) =
    HH.div
      ([ HP.classes (dimensionClasses slot)
       , HC.style (C.height (C.pct size))
       ] <> dimensionEvents slot)
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-dim-inner"]
          , HC.style (dimensionStyles slot size)
          ]
          [ HH.button
              [ HP.classes [ HH.className "sd-pivot-options-label" ]
              , HE.onMouseDown (HE.input (\e → right ∘ OrderDimensionStart slot e))
              ]
              [ HH.text (showJCursor dim) ]
          , HH.button
              [ HP.classes [ HH.className "sd-dismiss-button" ]
              , HP.title "Delete dimension"
              , ARIA.label "Delete dimension"
              , HE.onClick (HE.input_ (right ∘ RemoveDimension slot))
              ]
              [ HH.text "×"]
          ]
      ]

  dimensionClasses slot =
    [ HH.className "sd-pivot-options-dim" ] <>
      case st.orderingDimension of
        Just opts | opts.source == slot → [ HH.className "ordering" ]
        Just opts | opts.over == Just slot → [ HH.className "ordering-over" ]
        _ → []

  dimensionStyles slot size = do
    case st.orderingDimension of
      Just opts | opts.source == slot → C.top (C.px opts.offset)
      _ → pure unit

  dimensionEvents slot =
    if isJust st.orderingDimension
      then
        [ HE.onMouseOver (HE.input_ (right ∘ OrderOverDimension slot))
        , HE.onMouseOut (HE.input_ (right ∘ OrderOutDimension slot))
        ]
      else
        []

  renderedColumns =
    let
      len  = Array.length st.columns + 1
      size = 100.0 / toNumber len
    in
      map (renderColumn size) st.columns <>
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-col" ]
          , HC.style (C.width (C.pct size))
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-inner"] ]
              [ HH.div
                  [ HP.classes [ HH.className "sd-pivot-options-col-value" ] ]
                  [ HH.button
                      [ HP.classes [ HH.className "sd-pivot-options-plus" ]
                      , HE.onClick (HE.input_ (right ∘ AddColumn))
                      ]
                      []
                  ]
              , HH.div
                  [ HP.classes [ HH.className "sd-pivot-options-col-aggregation" ] ]
                  []
              ]
          ]
      ]

  renderColumn size (slot × col) =
    HH.div
      ([ HP.classes (columnClasses slot)
       , HC.style (C.width (C.pct size))
       ] <> columnEvents slot)
      [ HH.div
          [ HP.classes [ HH.className "sd-pivot-options-col-inner"]
          , HC.style (columnStyles slot size)
          ]
          [ HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-value" ] ]
              [ HH.button
                  [ HP.classes [ HH.className "sd-pivot-options-label" ]
                  , HE.onMouseDown (HE.input (\e → right ∘ OrderColumnStart slot e))
                  ]
                  [ HH.text (showColumn col)
                  ]
              , HH.button
                  [ HP.classes [ HH.className "sd-dismiss-button" ]
                  , HP.title "Delete column"
                  , ARIA.label "Delete column"
                  , HE.onClick (HE.input_ (right ∘ RemoveColumn slot))
                  ]
                  [ HH.text "×"]
              ]
          , HH.div
              [ HP.classes [ HH.className "sd-pivot-options-col-aggregation" ] ]
              case col of
                Column { valueAggregation } → [ columnSelect slot valueAggregation ]
                _ → []
          ]
      ]

  columnClasses slot =
    [ HH.className "sd-pivot-options-col" ] <>
      case st.orderingColumn of
        Just opts | opts.source == slot → [ HH.className "ordering" ]
        Just opts | opts.over == Just slot → [ HH.className "ordering-over" ]
        _ → []

  columnStyles slot size = do
    case st.orderingColumn of
      Just opts | opts.source == slot → C.left (C.px opts.offset)
      _ → pure unit

  columnEvents slot =
    if isJust st.orderingColumn
      then
        [ HE.onMouseOver (HE.input_ (right ∘ OrderOverColumn slot))
        , HE.onMouseOut (HE.input_ (right ∘ OrderOutColumn slot))
        ]
      else
        []

  columnSelect slot ag =
    HH.div
      [ HP.classes [ HH.className "list-group" ] ]
      (map (selectBtn slot ag)
        [ Nothing
        , Just Ag.Maximum
        , Just Ag.Minimum
        , Just Ag.Average
        , Just Ag.Sum
        -- Not supported by the backend
        -- , Just Ag.Product
        ])

  selectBtn slot ag ctr =
    HH.button
      [ HP.classes
          ([ HH.className "list-group-item" ]
           <> (HH.className "active" <$ guard (ctr == ag)))
      , HE.onClick (HE.input_ (right ∘ ChooseAggregation slot ctr))
      ]
      [ HH.text (maybe "Tabulate" S.stringVal ctr) ]

  showColumn (Column { value }) = showJCursor value
  showColumn Count = "COUNT"

  showJCursor (J.JField i c) = i <> show c
  showJCursor c = show c

evalCard ∷ CC.CardEvalQuery ~> DSL
evalCard = case _ of
  CC.EvalCard info _ next → do
    case info.input of
      Just (Port.TaggedResource { axes }) →
        H.modify _ { axes = axes }
      _ → pure unit
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.BuildPivotTable ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.BuildPivotTable model →
        H.modify (stateFromModel model)
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalOptions ∷ Query ~> DSL
evalOptions = case _ of
  AddDimension next → do
    H.modify _ { selecting = Just Dim }
    pure next
  AddColumn next → do
    H.modify _ { selecting = Just Col }
    pure next
  RemoveDimension slot next → do
    H.modify \st →
      st { dimensions = Array.filter (not ∘ eq slot ∘ fst) st.dimensions }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  RemoveColumn slot next → do
    H.modify \st →
      st { columns = Array.filter (not ∘ eq slot ∘ fst) st.columns }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  OrderDimensionStart slot ev next → do
    let
      opts =
        { source: slot
        , over: Nothing
        , offset: 0.0
        }
    Drag.subscribe' ev (right ∘ H.action ∘ OrderingDimension slot)
    H.modify _ { orderingDimension = Just opts }
    pure next
  OrderingDimension slot ev next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      case ev of
        Drag.Move _ d →
          H.modify _ { orderingDimension = Just opts { offset = d.offsetY } }
        Drag.Done _ →
          case opts.over of
            Just slot' → do
              H.modify _
                { orderingDimension = Nothing
                , dimensions = reorder slot slot' st.dimensions
                }
              CC.raiseUpdatedP' CC.EvalModelUpdate
            Nothing →
              H.modify _ { orderingDimension = Nothing }
    pure next
  OrderOverDimension slot next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      H.modify _ { orderingDimension = Just (opts { over = Just slot }) }
    pure next
  OrderOutDimension slot next → do
    st ← H.get
    for_ st.orderingDimension \opts →
      H.modify _ { orderingDimension = Just (opts { over = Nothing }) }
    pure next
  OrderColumnStart slot ev next → do
    let
      opts =
        { source: slot
        , over: Nothing
        , offset: 0.0
        }
    Drag.subscribe' ev (right ∘ H.action ∘ OrderingColumn slot)
    H.modify _ { orderingColumn = Just opts }
    pure next
  OrderingColumn slot ev next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      case ev of
        Drag.Move _ d →
          H.modify _ { orderingColumn = Just opts { offset = d.offsetX } }
        Drag.Done _ →
          case opts.over of
            Just slot' → do
              H.modify _
                { orderingColumn = Nothing
                , columns = reorder slot slot' st.columns
                }
              CC.raiseUpdatedP' CC.EvalModelUpdate
            Nothing →
              H.modify _ { orderingColumn = Nothing }
    pure next
  OrderOverColumn slot next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      H.modify _ { orderingColumn = Just (opts { over = Just slot }) }
    pure next
  OrderOutColumn slot next → do
    st ← H.get
    for_ st.orderingColumn \opts →
      H.modify _ { orderingColumn = Just (opts { over = Nothing }) }
    pure next
  ChooseAggregation slot ag next → do
    st ← H.get
    H.modify (setColumnAggregation slot ag)
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next

peek ∷ ∀ a. H.ChildF PCS.ChildSlot PCS.ChildQuery a → DSL Unit
peek = (coproduct peekSelectDim peekSelectCol) ∘ H.runChildF
  where
  peekSelectDim = case _ of
    DPC.Dismiss _ →
      H.modify _ { selecting = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      H.modify _
        { fresh = st.fresh + 1
        , dimensions = Array.snoc st.dimensions (st.fresh × value)
        , selecting = Nothing
        }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ →
      pure unit

  peekSelectCol = case _ of
    DPC.Dismiss _ →
      H.modify _ { selecting = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      H.modify _
        { fresh = st.fresh + 1
        , columns = Array.snoc st.columns (st.fresh × value)
        , selecting = Nothing
        }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ →
      pure unit


Fix warnings

Fix warnings

module Run.Choose
  ( liftChoose
  , cempty
  , calt
  , runChoose
  , module Run.Internal
  ) where

import Prelude

import Control.Alternative (class Alternative, alt, empty )
import Data.Either (Either(..))
import Run (Run)
import Run as Run
import Run.Internal (Choose(..), CHOOSE, _choose)

liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a
liftChoose = Run.lift _choose

cempty ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a
cempty = empty

calt ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a
calt = alt

runChoose ∷ ∀ f a r. Alternative f ⇒ Run (choose ∷ CHOOSE | r) a → Run r (f a)
runChoose = loop
  where
  handle = Run.on _choose Left Right
  loop r = case Run.peel r of
    Left a → case handle a of
      Left a' → case a' of
        Empty → pure empty
        Alt k → do
          x ← loop (k true)
          y ← loop (k false)
          pure (alt x y)
      Right a' →
        Run.send a' >>= loop
    Right a →
        pure (pure a)

module Run.Choose
  ( liftChoose
  , cempty
  , calt
  , runChoose
  , module Run.Internal
  ) where

import Prelude

import Control.Alternative (class Alternative, alt, empty )
import Data.Either (Either(..))
import Run (Run)
import Run as Run
import Run.Internal (Choose(..), CHOOSE, _choose)

liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a
liftChoose = Run.lift _choose

cempty ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a
cempty = empty

calt ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a
calt = alt

runChoose ∷ ∀ f a r. Alternative f ⇒ Run (choose ∷ CHOOSE | r) a → Run r (f a)
runChoose = loop
  where
  handle = Run.on _choose Left Right
  loop r = case Run.peel r of
    Left a → case handle a of
      Left a → case a of
        Empty → pure empty
        Alt k → do
          l ← loop (k true)
          r ← loop (k false)
          pure (alt l r)
      Right a' →
        Run.send a' >>= loop
    Right a →
        pure (pure a)


Add zpWithA

Add zpWithA

module Data.Traversable where

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

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

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

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

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

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

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

  sequence (Ref x) = Ref <$> x

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

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

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

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

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

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

module Data.Traversable where

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

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

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

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

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

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

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

  sequence (Ref x) = Ref <$> x

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

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

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

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

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