[CSE-31] Fix of accessing lang using a lens

module Explorer.View.Dashboard (dashboardView) where

import Prelude
import Data.Array (null, slice)
import Data.Lens (Lens', (^.))
import Data.Map (Map, fromFoldable, lookup, toAscUnfoldable) as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime.Lenses (_NominalDiffTime)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (dbLastBlocks, dbExploreBlocks, cAge, common, cExpand, cHeight, cRelayedBy, cSizeKB, cTotalSent, cTransactions, dashboard, hero, hrTitle, hrSearch, hrSubtitle, cTransactionFeed) as I18nL
import Explorer.Lenses.State (blocksExpanded, dashboard, lang, latestBlocks, latestTransactions, searchInput, selectedApiCode, transactionsExpanded, viewStates)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), DashboardAPICode(..), DashboardViewState, State, CBlockEntries, CTxEntries)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CTxEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeHeight, cbeRelayedBy, cbeSize, cbeTimeIssued, cbeTotalSent, cbeTxNum, cteId, cteAmount, cteTimeIssued, _CTxId, _CHash)
import Pos.Types.Lenses.Core (_Coin, getCoin)
import Pux.Html (Html, div, h3, text, h1, h2, input, h4, p, code) as P
import Pux.Html.Attributes (className, type_, placeholder) as P
import Pux.Html.Events (onClick, onFocus, onBlur) as P
import Explorer.Routes (Route(..), toUrl)
import Pux.Router (link) as P

dashboardView :: State -> P.Html Action
dashboardView state =
    P.div
        [ P.className "explorer-dashboard" ]
        [ heroView state
        , networkView state
        , blocksView state
        , transactionsView state
        , offerView state
        , apiView state
        ]

-- header view

newtype HeaderOptions = HeaderOptions
    { headline :: String
    , link :: Maybe HeaderLink
    }

newtype HeaderLink = HeaderLink
    { label :: String
    , action :: Action
    }

headerView :: State -> HeaderOptions -> P.Html Action
headerView state (HeaderOptions options) =
    P.div
        [ P.className "explorer-dashboard__header" ]
        [ P.h3
            [ P.className "headline"]
            [ P.text options.headline ]
        , P.div
            [ P.className "more__container"]
            [ linkView options.link ]
        ]
    where
      linkView link = case link of
          Just (HeaderLink link') ->
              P.div
                  [ P.className "more__link bg-arrow-right" ]
                  [ P.text link'.label ]
          Nothing -> P.div [] []

-- hero

heroView :: State -> P.Html Action
heroView state =
    let
        searchInputFocused = state ^. (dashboardViewState <<< searchInput)
        focusedClazz = if searchInputFocused then " focused" else ""
        searchIconClazz = if searchInputFocused then " bg-icon-search-hover" else " bg-icon-search"
    in
    P.div
        [ P.className "explorer-dashboard__hero" ]
        [ P.div
            [ P.className "hero-container" ]
            [ P.h1
                [ P.className "hero-headline" ]
                [ P.text $ translate (I18nL.hero <<< I18nL.hrTitle) state.lang ]
            , P.h2
                [ P.className "hero-subheadline"]
                [ P.text $ translate (I18nL.hero <<< I18nL.hrSubtitle) state.lang ]
            , P.div
                [ P.className $ "hero-search-container" <> focusedClazz ]
                [ P.input
                    [ P.className $ "hero-input" <> focusedClazz
                      , P.type_ "text"
                      , P.placeholder $ if searchInputFocused
                                        then ""
                                        else translate (I18nL.hero <<< I18nL.hrSearch) state.lang
                      , P.onFocus <<< const $ DashboardFocusSearchInput true
                      , P.onBlur <<< const $ DashboardFocusSearchInput false ]
                    []
                , P.div
                    [ P.className $ "hero-search-btn" <> searchIconClazz <> focusedClazz
                    , P.onClick $ const Search ]
                    []
                ]
            ]
        ]

-- network

-- FIXME (jk): just for now, will use later `real` ADTs
type NetworkItems = Array NetworkItem

-- FIXME (jk): just for now, will use later `real` ADTs
type NetworkItem =
    { headline :: String
    , subheadline :: String
    , description :: String
    }

networkItems :: NetworkItems
networkItems =
    [ { headline: "Last Block", subheadline: "123456"
      , description: "generated on 01.01.2017 12:00:00 \n\n 50 transactions" }
    , { headline: "Network difficulty", subheadline: "1,234,567,890.12"
      , description: "Difficulty is a measure of how difficult it is to find a new block below a given target." }
    , { headline: "Price (average)", subheadline: "1,000,000$ for 1 ADA"
      , description: "20% more since yesterday." }
    , { headline: "Total supply", subheadline: "9,876,543,210 ADA"
      , description: "Amount of ADA in the system." }
    , { headline: "Transactions", subheadline: "82,491,247,592,742,929"
      , description: "Total amount of transactions detected in system since the beginning." }
    ]

networkView :: State -> P.Html Action
networkView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ P.h3
                [ P.className "headline"]
                [ P.text "#Network" ]
          , P.div
                [ P.className "explorer-dashboard__teaser" ]
                $ map (networkItem state) networkItems
          ]
        ]

networkItem :: State -> NetworkItem -> P.Html Action
networkItem state item =
    P.div
        [ P.className "teaser-item" ]
        [ P.h3
            [ P.className "teaser-item__headline" ]
            [ P.text item.headline ]
        , P.h4
              [ P.className $ "teaser-item__subheadline" ]
              [ P.text item.subheadline ]
        , P.p
              [ P.className $ "teaser-item__description" ]
              [ P.text item.description ]
        ]

-- blocks

blocksView :: State -> P.Html Action
blocksView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
            [ P.className "explorer-dashboard__container" ]
            [ headerView state headerOptions
            , blocksHeaderView state
            , P.div
                [ P.className $ "blocks-waiting" <> visibleWaitingClazz ]
                [ P.text "#no data"]
            , P.div
                [ P.className $ "blocks-body" <> visibleBlockClazz ]
                $ map (blockRow state) latestBlocks'
            , P.div
                [ P.className $ "blocks-footer" <> visibleBlockClazz ]
                [ blocksFooterView ]
            -- TODO (jk) For debugging only - has to be removed later on
            , P.div
                [ P.className $ "btn-debug"
                , P.onClick $ const RequestLatestBlocks  ]
                [ P.text "#Debug blocks" ]
            ]
        ]
      where
        headerOptions = HeaderOptions
            { headline: translate (I18nL.dashboard <<< I18nL.dbLastBlocks) lang'
            , link: Just $ HeaderLink { label: translate (I18nL.dashboard <<< I18nL.dbExploreBlocks) lang'
                                      , action: NoOp }
            }
        lang' = state ^. lang
        expanded = state ^. dashboardBlocksExpanded
        blocks = state ^. latestBlocks
        noBlocks = null blocks
        visibleBlockClazz = if noBlocks then " invisible" else ""
        visibleWaitingClazz = if not noBlocks then " invisible" else ""
        -- TODO (jk) use pagination
        latestBlocks' :: CBlockEntries
        latestBlocks' = if expanded
            then slice 0 maxBlockRows blocks
            else slice 0 minBlockRows blocks

        blocksFooterView :: P.Html Action
        blocksFooterView = if expanded then
            paginationView state
            else
            P.div
              [ P.className "btn-expand"
              , P.onClick <<< const $ DashboardExpandBlocks true ]
              [ P.text $ translate (I18nL.common <<< I18nL.cExpand) lang']

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className "blocks-body__row" ]
        [ blockColumn <<< show $ entry ^. cbeHeight
        , blockColumn <<< show <<< unwrap $ entry ^. (cbeTimeIssued <<< _NominalDiffTime)
        , blockColumn <<< show $ entry ^. cbeTxNum
        , blockColumn <<< show $ entry ^. (cbeTotalSent <<< _Coin <<< getCoin)
        , blockColumn <<< fromMaybe "#Unknown" $ entry ^. cbeRelayedBy
        , blockColumn <<< show $ entry ^. cbeSize
        ]

blockColumn :: String -> P.Html Action
blockColumn value =
    P.div
        [ P.className "blocks-body__column" ]
        [ P.text value ]

blocksHeaderView :: State -> P.Html Action
blocksHeaderView state =
    P.div
          [ P.className $ "blocks-header" <> if null $ state ^. latestBlocks then " invisible" else "" ]
          $ map (blockHeaderItemView state) $ mkBlocksHeaderItems state.lang

blockHeaderItemView :: State -> String -> P.Html Action
blockHeaderItemView state label =
    P.div
        [ P.className "blocks-header__item" ]
        [ P.text label ]

mkBlocksHeaderItems :: Language -> Array String
mkBlocksHeaderItems lang =
    [ translate (I18nL.common <<< I18nL.cHeight) lang
    , translate (I18nL.common <<< I18nL.cAge) lang
    , translate (I18nL.common <<< I18nL.cTransactions) lang
    , translate (I18nL.common <<< I18nL.cTotalSent) lang
    , translate (I18nL.common <<< I18nL.cRelayedBy) lang
    , translate (I18nL.common <<< I18nL.cSizeKB) lang
    ]

-- transactions

maxTransactionRows :: Int
maxTransactionRows = 10

minTransactionRows :: Int
minTransactionRows = 5

transactionsView :: State -> P.Html Action
transactionsView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ headerView state headerOptions
          , P.div
              [ P.className $ "transactions__waiting" <> visibleWaitingClazz ]
              [ P.text "#no data"]
          , P.div
              [ P.className $ "transactions__container" <> visibleTxClazz ]
              $ map (transactionRow state) $ transactions'
          , P.div
            [ P.className $ "transactions__footer" <> visibleTxClazz ]
            [ P.div
                [ P.className "btn-expand"
                , P.onClick <<< const <<< DashboardExpandTransactions $ not expanded ]
                [ P.text expandLabel]
            ]
          -- TODO (jk) For debugging only - has to be removed later
          , P.div
              [ P.className $ "btn-debug"
              , P.onClick $ const RequestLatestTransactions  ]
              [ P.text "#Debug txs" ]
          ]
        ]
    where
      expanded = state ^. dashboardTransactionsExpanded
      expandLabel = if expanded then "#collapse" else "#expand"
      headerOptions = HeaderOptions
          { headline: translate (I18nL.common <<< I18nL.cTransactionFeed) state.lang
          , link: Just $ HeaderLink { label: "#Explore transactions", action: NoOp }
          }
      transactions = state ^. latestTransactions
      noTransactions = null transactions
      visibleTxClazz = if noTransactions then " invisible" else ""
      visibleWaitingClazz = if not noTransactions then " invisible" else ""
      transactions' :: CTxEntries
      transactions' = if expanded
          then slice 0 maxTransactionRows transactions
          else slice 0 minTransactionRows transactions

transactionRow :: State -> CTxEntry -> P.Html Action
transactionRow state (CTxEntry entry) =
    let txId = entry ^. (cteId <<< _CTxId <<< _CHash) in
    P.div
        [ P.className "transactions__row" ]
        [ P.link (toUrl <<< Transaction $ entry ^. cteId <<< _CTxId)
              [ P.className "transactions__column hash" ]
              [ P.text $ entry ^. (cteId <<< _CTxId <<< _CHash) ]
        , transactionColumn (show <<< unwrap $ entry ^. (cteTimeIssued <<< _NominalDiffTime)) ""
        , transactionColumn (show $ entry ^. (cteAmount <<< _Coin <<< getCoin)) <<< currencyCSSClass $ Just ADA
        ]

transactionColumn :: String -> String -> P.Html Action
transactionColumn value clazzName =
    P.div
        [ P.className $ "transactions__column " <> clazzName ]
        [ P.text value ]

-- offer

-- FIXME (jk): just for now, will use later `real` ADTs
type OfferItems = Array OfferItem

-- FIXME (jk): just for now, will use later `real` ADTs
type OfferItem =
    { headline :: String
    , description :: String
    }

offerItems :: OfferItems
offerItems =
    [ { headline: "Block Search"
      , description: "Block is a box where transactions are stored." }
    , { headline: "Address Search"
      , description: "Address is similar to what an account in ordinary bank is." }
    , { headline: "Transactions Search"
      , description: "Transaction is transfer of coins from user A to user B." }
    , { headline: "API"
      , description: "Our robust API is available in a variety of languages & SDKs." }
    ]

offerView :: State -> P.Html Action
offerView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ P.h3
                [ P.className "headline"]
                [ P.text "#WHAT DO WE OFFER ON OUR BLOCK EXPLORER" ]
          , P.div
                [ P.className "explorer-dashboard__teaser" ]
                $ map (offerItem state) offerItems
          ]
        ]

offerItem :: State -> OfferItem -> P.Html Action
offerItem state item =
    P.div
        [ P.className "teaser-item" ]
        [ P.h3
            [ P.className "teaser-item__headline" ]
            [ P.text item.headline ]
        , P.p
              [ P.className $ "teaser-item__description" ]
              [ P.text item.description ]
        ]

-- API

type ApiTabLabel = String

type ApiCode =
    { getAddress :: String
    , response :: String
    }

emptyApiCode :: ApiCode
emptyApiCode = { getAddress: "", response: ""}

apiCodes :: M.Map DashboardAPICode ApiCode
apiCodes =
  M.fromFoldable([
    Tuple Curl { getAddress: "Curl getAddress", response: "{\n\t\"hash\": }"}
    , Tuple Node { getAddress: "Node getAddress", response: "Node response ..."}
    , Tuple JQuery { getAddress: "jQuery getAddress", response: "jQuery response ..."}
    ])

apiView :: State -> P.Html Action
apiView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ headerView state headerOptions
          , P.div
            [ P.className "api-content" ]
            [ P.div
                [ P.className "api-content__container api-code"]
                [ P.div
                  [ P.className "api-code__tabs" ]
                  $ map (apiCodeTabView state) $ M.toAscUnfoldable apiTabs
                , apiCodeSnippetView "#Get Address" addressSnippet
                , apiCodeSnippetView "#Get Response" responseSnippet
                ]
            , P.div
                [ P.className "api-content__container api-about"]
                [ P.h3
                    [ P.className "api-about__headline" ]
                    [ P.text "#About Blockchain" ]
                , P.p
                    [ P.className "api-about__description" ]
                    [ P.text "#Blockchain API makes it easy yo build cryptocurrensies applications and features. We are focused on ... \n\n This API is free and unlimited while we are in beta. We are just getting started, and will be rolling out more ..."
                    ]
                , P.div
                  [ P.className "api-about__button" ]
                  [ P.text "#Get API Key"]
                ]
            ]
          ]
        ]
    where
      apiCode :: ApiCode
      apiCode = fromMaybe emptyApiCode $ M.lookup (state ^. dashboardSelectedApiCode) apiCodes
      addressSnippet = _.getAddress $ apiCode
      responseSnippet = _.response $ apiCode
      headerOptions = HeaderOptions
          { headline: "#API"
          , link: Just $ HeaderLink { label: "#See more examples", action: NoOp }
          }

apiTabs :: M.Map DashboardAPICode ApiTabLabel
apiTabs =
    M.fromFoldable(
        [ Tuple Curl "#Curl"
        , Tuple Node "#Node"
        , Tuple JQuery "#jQuery"
        ])

apiCodeTabView :: State -> Tuple DashboardAPICode ApiTabLabel -> P.Html Action
apiCodeTabView state (Tuple code label) =
    P.div
      [ P.className $ "api-code__tab " <> selectedClazz
      , P.onClick <<< const $ DashboardShowAPICode code ]
      [ P.text label ]
    where
      selectedClazz = if state ^. dashboardSelectedApiCode == code then "selected" else ""

apiCodeSnippetView :: String -> String -> P.Html Action
apiCodeSnippetView headline snippet =
    P.div
        [ P.className "api-snippet" ]
        [ P.h3
            [ P.className "api-snippet__headline" ]
            [ P.text headline ]
        , P.code
            [ P.className "api-snippet__code" ]
            [ P.text snippet ]

        ]

-- lenses

dashboardViewState :: Lens' State DashboardViewState
dashboardViewState = viewStates <<< dashboard

dashboardBlocksExpanded :: Lens' State Boolean
dashboardBlocksExpanded = dashboardViewState <<< blocksExpanded

dashboardTransactionsExpanded :: Lens' State Boolean
dashboardTransactionsExpanded = dashboardViewState <<< transactionsExpanded

dashboardSelectedApiCode :: Lens' State DashboardAPICode
dashboardSelectedApiCode = dashboardViewState <<< selectedApiCode

module Explorer.View.Dashboard (dashboardView) where

import Prelude
import Data.Array (null, slice)
import Data.Lens (Lens', (^.))
import Data.Map (Map, fromFoldable, lookup, toAscUnfoldable) as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime.Lenses (_NominalDiffTime)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (dbLastBlocks, dbExploreBlocks, cAge, common, cExpand, cHeight, cRelayedBy, cSizeKB, cTotalSent, cTransactions, dashboard, hero, hrTitle, hrSearch, hrSubtitle, cTransactionFeed) as I18nL
import Explorer.Lenses.State (blocksExpanded, dashboard, lang, latestBlocks, latestTransactions, searchInput, selectedApiCode, transactionsExpanded, viewStates)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), DashboardAPICode(..), DashboardViewState, State, CBlockEntries, CTxEntries)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CTxEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeHeight, cbeRelayedBy, cbeSize, cbeTimeIssued, cbeTotalSent, cbeTxNum, cteId, cteAmount, cteTimeIssued, _CTxId, _CHash)
import Pos.Types.Lenses.Core (_Coin, getCoin)
import Pux.Html (Html, div, h3, text, h1, h2, input, h4, p, code) as P
import Pux.Html.Attributes (className, type_, placeholder) as P
import Pux.Html.Events (onClick, onFocus, onBlur) as P
import Explorer.Routes (Route(..), toUrl)
import Pux.Router (link) as P

dashboardView :: State -> P.Html Action
dashboardView state =
    P.div
        [ P.className "explorer-dashboard" ]
        [ heroView state
        , networkView state
        , blocksView state
        , transactionsView state
        , offerView state
        , apiView state
        ]

-- header view

newtype HeaderOptions = HeaderOptions
    { headline :: String
    , link :: Maybe HeaderLink
    }

newtype HeaderLink = HeaderLink
    { label :: String
    , action :: Action
    }

headerView :: State -> HeaderOptions -> P.Html Action
headerView state (HeaderOptions options) =
    P.div
        [ P.className "explorer-dashboard__header" ]
        [ P.h3
            [ P.className "headline"]
            [ P.text options.headline ]
        , P.div
            [ P.className "more__container"]
            [ linkView options.link ]
        ]
    where
      linkView link = case link of
          Just (HeaderLink link') ->
              P.div
                  [ P.className "more__link bg-arrow-right" ]
                  [ P.text link'.label ]
          Nothing -> P.div [] []

-- hero

heroView :: State -> P.Html Action
heroView state =
    let
        searchInputFocused = state ^. (dashboardViewState <<< searchInput)
        focusedClazz = if searchInputFocused then " focused" else ""
        searchIconClazz = if searchInputFocused then " bg-icon-search-hover" else " bg-icon-search"
    in
    P.div
        [ P.className "explorer-dashboard__hero" ]
        [ P.div
            [ P.className "hero-container" ]
            [ P.h1
                [ P.className "hero-headline" ]
                [ P.text $ translate (I18nL.hero <<< I18nL.hrTitle) state.lang ]
            , P.h2
                [ P.className "hero-subheadline"]
                [ P.text $ translate (I18nL.hero <<< I18nL.hrSubtitle) state.lang ]
            , P.div
                [ P.className $ "hero-search-container" <> focusedClazz ]
                [ P.input
                    [ P.className $ "hero-input" <> focusedClazz
                      , P.type_ "text"
                      , P.placeholder $ if searchInputFocused
                                        then ""
                                        else translate (I18nL.hero <<< I18nL.hrSearch) state.lang
                      , P.onFocus <<< const $ DashboardFocusSearchInput true
                      , P.onBlur <<< const $ DashboardFocusSearchInput false ]
                    []
                , P.div
                    [ P.className $ "hero-search-btn" <> searchIconClazz <> focusedClazz
                    , P.onClick $ const Search ]
                    []
                ]
            ]
        ]

-- network

-- FIXME (jk): just for now, will use later `real` ADTs
type NetworkItems = Array NetworkItem

-- FIXME (jk): just for now, will use later `real` ADTs
type NetworkItem =
    { headline :: String
    , subheadline :: String
    , description :: String
    }

networkItems :: NetworkItems
networkItems =
    [ { headline: "Last Block", subheadline: "123456"
      , description: "generated on 01.01.2017 12:00:00 \n\n 50 transactions" }
    , { headline: "Network difficulty", subheadline: "1,234,567,890.12"
      , description: "Difficulty is a measure of how difficult it is to find a new block below a given target." }
    , { headline: "Price (average)", subheadline: "1,000,000$ for 1 ADA"
      , description: "20% more since yesterday." }
    , { headline: "Total supply", subheadline: "9,876,543,210 ADA"
      , description: "Amount of ADA in the system." }
    , { headline: "Transactions", subheadline: "82,491,247,592,742,929"
      , description: "Total amount of transactions detected in system since the beginning." }
    ]

networkView :: State -> P.Html Action
networkView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ P.h3
                [ P.className "headline"]
                [ P.text "#Network" ]
          , P.div
                [ P.className "explorer-dashboard__teaser" ]
                $ map (networkItem state) networkItems
          ]
        ]

networkItem :: State -> NetworkItem -> P.Html Action
networkItem state item =
    P.div
        [ P.className "teaser-item" ]
        [ P.h3
            [ P.className "teaser-item__headline" ]
            [ P.text item.headline ]
        , P.h4
              [ P.className $ "teaser-item__subheadline" ]
              [ P.text item.subheadline ]
        , P.p
              [ P.className $ "teaser-item__description" ]
              [ P.text item.description ]
        ]

-- blocks

blocksView :: State -> P.Html Action
blocksView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
            [ P.className "explorer-dashboard__container" ]
            [ headerView state headerOptions
            , blocksHeaderView state
            , P.div
                [ P.className $ "blocks-waiting" <> visibleWaitingClazz ]
                [ P.text "#no data"]
            , P.div
                [ P.className $ "blocks-body" <> visibleBlockClazz ]
                $ map (blockRow state) latestBlocks'
            , P.div
                [ P.className $ "blocks-footer" <> visibleBlockClazz ]
                [ blocksFooterView ]
            -- TODO (jk) For debugging only - has to be removed later on
            , P.div
                [ P.className $ "btn-debug"
                , P.onClick $ const RequestLatestBlocks  ]
                [ P.text "#Debug blocks" ]
            ]
        ]
      where
        headerOptions = HeaderOptions
            { headline: translate (I18nL.dashboard <<< I18nL.dbLastBlocks) lang
            , link: Just $ HeaderLink { label: translate (I18nL.dashboard <<< I18nL.dbExploreBlocks) lang
                                      , action: NoOp }
            }
        lang = state ^. lang
        expanded = state ^. dashboardBlocksExpanded
        blocks = state ^. latestBlocks
        noBlocks = null blocks
        visibleBlockClazz = if noBlocks then " invisible" else ""
        visibleWaitingClazz = if not noBlocks then " invisible" else ""
        -- TODO (jk) use pagination
        latestBlocks' :: CBlockEntries
        latestBlocks' = if expanded
            then slice 0 maxBlockRows blocks
            else slice 0 minBlockRows blocks

        blocksFooterView :: P.Html Action
        blocksFooterView = if expanded then
            paginationView state
            else
            P.div
              [ P.className "btn-expand"
              , P.onClick <<< const $ DashboardExpandBlocks true ]
              [ P.text $ translate (I18nL.common <<< I18nL.cExpand) lang]

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className "blocks-body__row" ]
        [ blockColumn <<< show $ entry ^. cbeHeight
        , blockColumn <<< show <<< unwrap $ entry ^. (cbeTimeIssued <<< _NominalDiffTime)
        , blockColumn <<< show $ entry ^. cbeTxNum
        , blockColumn <<< show $ entry ^. (cbeTotalSent <<< _Coin <<< getCoin)
        , blockColumn <<< fromMaybe "#Unknown" $ entry ^. cbeRelayedBy
        , blockColumn <<< show $ entry ^. cbeSize
        ]

blockColumn :: String -> P.Html Action
blockColumn value =
    P.div
        [ P.className "blocks-body__column" ]
        [ P.text value ]

blocksHeaderView :: State -> P.Html Action
blocksHeaderView state =
    P.div
          [ P.className $ "blocks-header" <> if null $ state ^. latestBlocks then " invisible" else "" ]
          $ map (blockHeaderItemView state) $ mkBlocksHeaderItems state.lang

blockHeaderItemView :: State -> String -> P.Html Action
blockHeaderItemView state label =
    P.div
        [ P.className "blocks-header__item" ]
        [ P.text label ]

mkBlocksHeaderItems :: Language -> Array String
mkBlocksHeaderItems lang =
    [ translate (I18nL.common <<< I18nL.cHeight) lang
    , translate (I18nL.common <<< I18nL.cAge) lang
    , translate (I18nL.common <<< I18nL.cTransactions) lang
    , translate (I18nL.common <<< I18nL.cTotalSent) lang
    , translate (I18nL.common <<< I18nL.cRelayedBy) lang
    , translate (I18nL.common <<< I18nL.cSizeKB) lang
    ]

-- transactions

maxTransactionRows :: Int
maxTransactionRows = 10

minTransactionRows :: Int
minTransactionRows = 5

transactionsView :: State -> P.Html Action
transactionsView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ headerView state headerOptions
          , P.div
              [ P.className $ "transactions__waiting" <> visibleWaitingClazz ]
              [ P.text "#no data"]
          , P.div
              [ P.className $ "transactions__container" <> visibleTxClazz ]
              $ map (transactionRow state) $ transactions'
          , P.div
            [ P.className $ "transactions__footer" <> visibleTxClazz ]
            [ P.div
                [ P.className "btn-expand"
                , P.onClick <<< const <<< DashboardExpandTransactions $ not expanded ]
                [ P.text expandLabel]
            ]
          -- TODO (jk) For debugging only - has to be removed later
          , P.div
              [ P.className $ "btn-debug"
              , P.onClick $ const RequestLatestTransactions  ]
              [ P.text "#Debug txs" ]
          ]
        ]
    where
      expanded = state ^. dashboardTransactionsExpanded
      expandLabel = if expanded then "#collapse" else "#expand"
      headerOptions = HeaderOptions
          { headline: translate (I18nL.common <<< I18nL.cTransactionFeed) state.lang
          , link: Just $ HeaderLink { label: "#Explore transactions", action: NoOp }
          }
      transactions = state ^. latestTransactions
      noTransactions = null transactions
      visibleTxClazz = if noTransactions then " invisible" else ""
      visibleWaitingClazz = if not noTransactions then " invisible" else ""
      transactions' :: CTxEntries
      transactions' = if expanded
          then slice 0 maxTransactionRows transactions
          else slice 0 minTransactionRows transactions

transactionRow :: State -> CTxEntry -> P.Html Action
transactionRow state (CTxEntry entry) =
    let txId = entry ^. (cteId <<< _CTxId <<< _CHash) in
    P.div
        [ P.className "transactions__row" ]
        [ P.link (toUrl <<< Transaction $ entry ^. cteId <<< _CTxId)
              [ P.className "transactions__column hash" ]
              [ P.text $ entry ^. (cteId <<< _CTxId <<< _CHash) ]
        , transactionColumn (show <<< unwrap $ entry ^. (cteTimeIssued <<< _NominalDiffTime)) ""
        , transactionColumn (show $ entry ^. (cteAmount <<< _Coin <<< getCoin)) <<< currencyCSSClass $ Just ADA
        ]

transactionColumn :: String -> String -> P.Html Action
transactionColumn value clazzName =
    P.div
        [ P.className $ "transactions__column " <> clazzName ]
        [ P.text value ]

-- offer

-- FIXME (jk): just for now, will use later `real` ADTs
type OfferItems = Array OfferItem

-- FIXME (jk): just for now, will use later `real` ADTs
type OfferItem =
    { headline :: String
    , description :: String
    }

offerItems :: OfferItems
offerItems =
    [ { headline: "Block Search"
      , description: "Block is a box where transactions are stored." }
    , { headline: "Address Search"
      , description: "Address is similar to what an account in ordinary bank is." }
    , { headline: "Transactions Search"
      , description: "Transaction is transfer of coins from user A to user B." }
    , { headline: "API"
      , description: "Our robust API is available in a variety of languages & SDKs." }
    ]

offerView :: State -> P.Html Action
offerView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ P.h3
                [ P.className "headline"]
                [ P.text "#WHAT DO WE OFFER ON OUR BLOCK EXPLORER" ]
          , P.div
                [ P.className "explorer-dashboard__teaser" ]
                $ map (offerItem state) offerItems
          ]
        ]

offerItem :: State -> OfferItem -> P.Html Action
offerItem state item =
    P.div
        [ P.className "teaser-item" ]
        [ P.h3
            [ P.className "teaser-item__headline" ]
            [ P.text item.headline ]
        , P.p
              [ P.className $ "teaser-item__description" ]
              [ P.text item.description ]
        ]

-- API

type ApiTabLabel = String

type ApiCode =
    { getAddress :: String
    , response :: String
    }

emptyApiCode :: ApiCode
emptyApiCode = { getAddress: "", response: ""}

apiCodes :: M.Map DashboardAPICode ApiCode
apiCodes =
  M.fromFoldable([
    Tuple Curl { getAddress: "Curl getAddress", response: "{\n\t\"hash\": }"}
    , Tuple Node { getAddress: "Node getAddress", response: "Node response ..."}
    , Tuple JQuery { getAddress: "jQuery getAddress", response: "jQuery response ..."}
    ])

apiView :: State -> P.Html Action
apiView state =
    P.div
        [ P.className "explorer-dashboard__wrapper" ]
        [ P.div
          [ P.className "explorer-dashboard__container" ]
          [ headerView state headerOptions
          , P.div
            [ P.className "api-content" ]
            [ P.div
                [ P.className "api-content__container api-code"]
                [ P.div
                  [ P.className "api-code__tabs" ]
                  $ map (apiCodeTabView state) $ M.toAscUnfoldable apiTabs
                , apiCodeSnippetView "#Get Address" addressSnippet
                , apiCodeSnippetView "#Get Response" responseSnippet
                ]
            , P.div
                [ P.className "api-content__container api-about"]
                [ P.h3
                    [ P.className "api-about__headline" ]
                    [ P.text "#About Blockchain" ]
                , P.p
                    [ P.className "api-about__description" ]
                    [ P.text "#Blockchain API makes it easy yo build cryptocurrensies applications and features. We are focused on ... \n\n This API is free and unlimited while we are in beta. We are just getting started, and will be rolling out more ..."
                    ]
                , P.div
                  [ P.className "api-about__button" ]
                  [ P.text "#Get API Key"]
                ]
            ]
          ]
        ]
    where
      apiCode :: ApiCode
      apiCode = fromMaybe emptyApiCode $ M.lookup (state ^. dashboardSelectedApiCode) apiCodes
      addressSnippet = _.getAddress $ apiCode
      responseSnippet = _.response $ apiCode
      headerOptions = HeaderOptions
          { headline: "#API"
          , link: Just $ HeaderLink { label: "#See more examples", action: NoOp }
          }

apiTabs :: M.Map DashboardAPICode ApiTabLabel
apiTabs =
    M.fromFoldable(
        [ Tuple Curl "#Curl"
        , Tuple Node "#Node"
        , Tuple JQuery "#jQuery"
        ])

apiCodeTabView :: State -> Tuple DashboardAPICode ApiTabLabel -> P.Html Action
apiCodeTabView state (Tuple code label) =
    P.div
      [ P.className $ "api-code__tab " <> selectedClazz
      , P.onClick <<< const $ DashboardShowAPICode code ]
      [ P.text label ]
    where
      selectedClazz = if state ^. dashboardSelectedApiCode == code then "selected" else ""

apiCodeSnippetView :: String -> String -> P.Html Action
apiCodeSnippetView headline snippet =
    P.div
        [ P.className "api-snippet" ]
        [ P.h3
            [ P.className "api-snippet__headline" ]
            [ P.text headline ]
        , P.code
            [ P.className "api-snippet__code" ]
            [ P.text snippet ]

        ]

-- lenses

dashboardViewState :: Lens' State DashboardViewState
dashboardViewState = viewStates <<< dashboard

dashboardBlocksExpanded :: Lens' State Boolean
dashboardBlocksExpanded = dashboardViewState <<< blocksExpanded

dashboardTransactionsExpanded :: Lens' State Boolean
dashboardTransactionsExpanded = dashboardViewState <<< transactionsExpanded

dashboardSelectedApiCode :: Lens' State DashboardAPICode
dashboardSelectedApiCode = dashboardViewState <<< selectedApiCode


Add tracksink config to browserconfig

Add tracksink config to browserconfig

module Genetics.Browser.Config
       ( BrowserConfig(..)
       , parseBrowserConfig
       ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Except (except, withExcept)
import Data.Argonaut (Json)
import Data.Bifunctor (lmap)
import Data.Either (Either)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readString, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Maybe (Maybe(Just))
import Data.StrMap (StrMap)
import Data.Traversable (traverse)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Biodalliance.Config (RendererInfo, parseRenderers)
import Genetics.Browser.Biodalliance.Types (Biodalliance)
import Genetics.Browser.Config.Track (TracksMap, readTracksMap)
import Genetics.Browser.Cytoscape.Types (Cytoscape)
import Genetics.Browser.Events.TrackSink (SinkConfig)
import Genetics.Browser.Events.TrackSource (SourceConfig, validateSourceConfig)
import Unsafe.Coerce (unsafeCoerce)

-- TODO `wrapRenderer` and `browser` should both be in a BD-specific config,
-- and be optional if there are no BD tracks.
-- | The configuration type for the whole browser
newtype BrowserConfig eb ec = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , bdRenderers :: StrMap RendererInfo
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      , events :: Maybe { bdEventSources :: Array SourceConfig
                                                        , cyEventSources :: Array SourceConfig
                                                        , bdEventSinks :: Array (SinkConfig
                                                                          (Biodalliance -> Eff eb Unit))
                                                        , cyEventSinks :: Array (SinkConfig
                                                                          (Cytoscape -> Eff ec Unit))
                                                        }
                                      }

readJson :: Foreign -> F Json
readJson f = pure $ unsafeCoerce f

readTaggedWithError :: forall a. String -> String -> Foreign -> F a
readTaggedWithError s e f = withExcept (append (pure $ ForeignError e)) $ unsafeReadTagged s f

parseSourceConfig :: Foreign -> F SourceConfig
parseSourceConfig f = do
  eventName     <- f ! "eventName" >>= readString
  eventTemplate <- f ! "eventTemplate" >>= readJson
  rawTemplate   <- f ! "rawTemplate" >>= readJson
  pure $ { eventName
         , eventTemplate
         , rawTemplate
         }

parseSinkConfig :: forall a. Foreign -> F (SinkConfig a)
parseSinkConfig f = do
  eventName <- f ! "eventName" >>= readString
  eventFun <- f ! "eventFun" >>=
              readTaggedWithError "Function" ("Error on sink config for event: " <> eventName)
  pure $ { eventName, eventFun }

eitherToF :: Either String ~> F
eitherToF = except <<< lmap (pure <<< ForeignError)

parseBrowserConfig :: forall eb ec. Foreign -> F (BrowserConfig eb ec)
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= readTaggedWithError "Function" "Error on 'wrapRenderer':"
  browser <- f ! "browser" >>= readTaggedWithError "Function" "Error on 'browser':"
  tracks <- f ! "tracks" >>= readTracksMap

  events <- do
    sources <- f ! "eventSources"
    bdSources <- sources ! "bd" >>= readArray >>= traverse parseSourceConfig
    cySources <- sources ! "cy" >>= readArray >>= traverse parseSourceConfig

    _ <- eitherToF $ traverse validateSourceConfig bdSources
    _ <- eitherToF $ traverse validateSourceConfig cySources

    sinks <- f ! "eventSinks"
    bdSinks <- sinks ! "bd" >>= readArray >>= traverse parseSinkConfig
    cySinks <- sinks ! "cy" >>= readArray >>= traverse parseSinkConfig

    pure $ Just $ { bdEventSources: bdSources
                  , cyEventSources: cySources
                  , bdEventSinks: bdSinks
                  , cyEventSinks: cySinks
                  }

  bdRenderers <- f ! "renderers" >>= parseRenderers
  pure $ BrowserConfig { wrapRenderer, bdRenderers, browser, tracks, events }

module Genetics.Browser.Config
       ( BrowserConfig(..)
       , parseBrowserConfig
       ) where

import Prelude

import Control.Monad.Except (except, throwError, withExcept)
import Data.Argonaut (Json)
import Data.Bifunctor (lmap)
import Data.Either (isLeft, Either(..))
import Data.Foldable (any)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readString, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Maybe (Maybe(..), isNothing)
import Data.StrMap (StrMap)
import Data.Traversable (traverse)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Biodalliance.Config (RendererInfo, parseRenderers)
import Genetics.Browser.Config.Track (TracksMap, readTracksMap)
import Genetics.Browser.Events.TrackSource (SourceConfig, makeTrackSource, validateSourceConfig)
import Unsafe.Coerce (unsafeCoerce)

-- TODO `wrapRenderer` and `browser` should both be in a BD-specific config,
-- and be optional if there are no BD tracks.
-- | The configuration type for the whole browser
newtype BrowserConfig = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , bdRenderers :: StrMap RendererInfo
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      , events :: Maybe { bdEventSources :: Array SourceConfig
                                                        , cyEventSources :: Array SourceConfig
                                                        }
                                      }

readJson :: Foreign -> F Json
readJson f = pure $ unsafeCoerce f

parseSourceConfig :: Foreign -> F SourceConfig
parseSourceConfig f = do
  eventName     <- f ! "eventName" >>= readString
  eventTemplate <- f ! "eventTemplate" >>= readJson
  rawTemplate   <- f ! "rawTemplate" >>= readJson
  pure $ { eventName
         , eventTemplate
         , rawTemplate
         }

readTaggedWithError :: forall a. String -> String -> Foreign -> F a
readTaggedWithError s e f = withExcept (append (pure $ ForeignError e)) $ unsafeReadTagged s f

eitherToF :: Either String ~> F
eitherToF = except <<< lmap (pure <<< ForeignError)

parseBrowserConfig :: Foreign -> F BrowserConfig
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= readTaggedWithError "Function" "Error on 'wrapRenderer':"
  browser <- f ! "browser" >>= readTaggedWithError "Function" "Error on 'browser':"
  tracks <- f ! "tracks" >>= readTracksMap

  events <- do
    evs <- f ! "eventSources"
    bd <- evs ! "bd" >>= readArray >>= traverse parseSourceConfig
    cy <- evs ! "cy" >>= readArray >>= traverse parseSourceConfig

    _ <- eitherToF $ traverse validateSourceConfig bd
    _ <- eitherToF $ traverse validateSourceConfig cy

    pure $ Just $ { bdEventSources: bd
                  , cyEventSources: cy
                  }

  bdRenderers <- f ! "renderers" >>= parseRenderers
  pure $ BrowserConfig { wrapRenderer, bdRenderers, browser, tracks, events }


Fix unstore bug

Fix unstore bug

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Data.Array ((..), (:))
import Data.Foldable
import Data.Maybe (Maybe(..))
import Prelude (bind, const, pure, (#), ($), (*), (+), (-), (<), (<#>), (<$>), (==), (>=))
import Control.MonadZero (guard)

type Board =
  { cells :: FM.FixedMatrix72 Pit
  , blockedCells :: Array PitRef
  , storeA :: Int
  , storeB :: Int
  }

type Pit = Int
type PitRef = FM.Ref
type Player = FM.Row

initPit :: Pit
initPit = 5

cols :: Int
cols = 7

rowCount :: Int
rowCount = cols * initPit

init' :: Int -> Board
init' perPit =
  { cells: FM.init perPit
  , blockedCells: []
  , storeA: 0
  , storeB: 0
  }

init :: Board
init = init' initPit

initWith' :: Int -> Int -> Int -> Board
initWith' a b perPit =
  init' 0
  # store A a
  # store B b
  # refillPlayer A
  # refillPlayer B
    where refillPlayer player board =
            foldl (refillPit player) board (refs player)
          refillPit player board ref =
            case unstoreToPit ref player perPit board of
              Just board' -> board'
              Nothing -> blockPit ref board

initWith :: Int -> Int -> Board
initWith a b | a < initPit  = initWith' a b 1
             | b < initPit  = initWith' a b 1
             | true         = initWith' a b 5

refs :: Player -> Array PitRef
refs A = FM.makeRef A <$> (cols-1)..0
refs B = FM.makeRef B <$> 0..(cols-1)

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 0 })   = Ref { row: B, idx: 0 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx - 1 }
nextRef (Ref { row: B, idx: 6 })   = Ref { row: A, idx: 6 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx + 1 }

blockPit :: PitRef -> Board -> Board
blockPit ref board = board { blockedCells = ref : board.blockedCells }

lookup :: PitRef -> Board -> Pit
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Pit -> a) -> Board -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Pit -> Pit -> a) -> Board -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Pit -> Pit -> Pit -> a) -> Board -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

belongsTo :: PitRef -> Player -> Boolean
belongsTo (Ref { row, idx }) player = row == player

modifyPit :: PitRef -> (Pit -> Pit) -> Board -> Board
modifyPit ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clearPit :: PitRef -> Board -> Board
clearPit pitRef = modifyPit pitRef (const 0)

setPit :: PitRef -> Int -> Board -> Board
setPit ref v = modifyPit ref (const v)

-- Move some seeds from a player's store to this pit
unstoreToPit :: PitRef -> Player -> Int -> Board -> Maybe Board
unstoreToPit ref player count board
    = unstore player count board
  <#> setPit ref count

-- Move all seeds from a pit to this player's store
storeFromPit :: Player -> Board -> PitRef -> Board
storeFromPit player board ref =
  board
  # clearPit ref
  # store player seeds
    where seeds = lookup ref board

store :: Player -> Int -> Board -> Board
store A seeds board = board { storeA = board.storeA + seeds }
store B seeds board = board { storeB = board.storeB + seeds }

unstore :: Player -> Int -> Board -> Maybe Board
unstore A count board = do
  guard $ board.storeA >= count
  pure $ board { storeA = board.storeA - count }
unstore B count board = do
  guard $ board.storeB >= count
  pure $ board { storeB = board.storeB - count }

getStore :: Player -> Board -> Pit
getStore A board = board.storeA
getStore B board = board.storeB

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Data.Array ((..), (:))
import Data.Foldable
import Data.Maybe (Maybe(..))
import Prelude (bind, const, flip, pure, (#), ($), (*), (+), (-), (<), (<#>), (<$>), (==), (>=))
import Control.MonadZero (guard)

type Board =
  { cells :: FM.FixedMatrix72 Pit
  , blockedCells :: Array PitRef
  , storeA :: Int
  , storeB :: Int
  }

type Pit = Int
type PitRef = FM.Ref
type Player = FM.Row

initPit :: Pit
initPit = 5

cols :: Int
cols = 7

rowCount :: Int
rowCount = cols * initPit

init' :: Int -> Board
init' perPit =
  { cells: FM.init perPit
  , blockedCells: []
  , storeA: 0
  , storeB: 0
  }

init :: Board
init = init' initPit

initWith' :: Int -> Int -> Int -> Board
initWith' a b perPit =
  init' 0
  # store A a
  # store B b
  # refillPlayer A
  # refillPlayer B
    where refillPlayer player = flip (foldl $ refillPit player) (refs player)
          refillPit player board ref =
            case unstoreToPit ref player perPit board of
              Just board' -> board'
              Nothing -> blockPit ref board

initWith :: Int -> Int -> Board
initWith a b | a < initPit  = initWith' a b 1
             | b < initPit  = initWith' a b 1
             | true         = initWith' a b 5

refs :: Player -> Array PitRef
refs A = FM.makeRef A <$> (cols-1)..0
refs B = FM.makeRef B <$> 0..(cols-1)

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 0 })   = Ref { row: B, idx: 0 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx - 1 }
nextRef (Ref { row: B, idx: 6 })   = Ref { row: A, idx: 6 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx + 1 }

blockPit :: PitRef -> Board -> Board
blockPit ref board = board { blockedCells = ref : board.blockedCells }

lookup :: PitRef -> Board -> Pit
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Pit -> a) -> Board -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Pit -> Pit -> a) -> Board -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Pit -> Pit -> Pit -> a) -> Board -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

belongsTo :: PitRef -> Player -> Boolean
belongsTo (Ref { row, idx }) player = row == player

modifyPit :: PitRef -> (Pit -> Pit) -> Board -> Board
modifyPit ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clearPit :: PitRef -> Board -> Board
clearPit pitRef = modifyPit pitRef (const 0)

setPit :: PitRef -> Int -> Board -> Board
setPit ref v = modifyPit ref (const v)

-- Move some seeds from a player's store to this pit
unstoreToPit :: PitRef -> Player -> Int -> Board -> Maybe Board
unstoreToPit ref player count board
    = unstore player count board
  <#> setPit ref count

-- Move all seeds from a pit to this player's store
storeFromPit :: Player -> Board -> PitRef -> Board
storeFromPit player board ref =
  board
  # clearPit ref
  # store player seeds
    where seeds = lookup ref board

store :: Player -> Pit -> Board -> Board
store A seeds board = board { storeA = board.storeA + seeds }
store B seeds board = board { storeB = board.storeB + seeds }

unstore :: Player -> Int -> Board -> Maybe Board
unstore A count board = do
  guard $ board.storeA >= count
  pure $ board { storeA = board.storeA - count }
unstore B count board = do
  guard $ board.storeB >= count
  pure $ board { storeA = board.storeB - count }

getStore :: Player -> Board -> Pit
getStore A board = board.storeA
getStore B board = board.storeB


only show topics that are not on the grid yet

module Render.Main where

import Render.Types
import Data.Array
import Data.Maybe
import qualified Data.Map as M
import Data.Tuple
import Control.Monad.Eff

import DOM

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = as { timeslots = M.insert s t as.timeslots }

removeTimeslot :: Slot -> AppState -> AppState
removeTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

removeTopic :: Topic -> AppState -> AppState
removeTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

selectTopic :: Topic -> AppState -> AppState
selectTopic topic as = as { selectedTopic = Just topic }

unselectTopic :: AppState -> AppState
unselectTopic as = as { selectedTopic = Nothing :: Maybe Topic }

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = t { typ = show t.typ }

sanitizeSlot :: Slot -> SanitizedSlot
sanitizeSlot (Slot s) = { room  : show s.room
                        , block : show s.block
                        }

sanitizeTimeslot :: Timeslot -> SanitizedTimeslot
sanitizeTimeslot (Tuple s t) = Tuple (sanitizeSlot s) (sanitizeTopic t)

sanitizeAppState :: AppState -> SanitizedAppState
sanitizeAppState as = let topicNotInGrid t = (filter (\t' -> t == t')(M.values as.timeslots)) == []
                      in { topics          : sanitizeTopic    <$> filter topicNotInGrid as.topics
                         , rooms           : as.rooms
                         , blocks          : as.blocks
                         , slots           : sanitizeSlot     <$> as.slots
                         , timeslots       : sanitizeTimeslot <$> (M.toList as.timeslots)
                         , selectedTopic   : sanitizeTopic    <$> as.selectedTopic
                         }

findIn :: Room -> Block -> [SanitizedTimeslot] -> Maybe SanitizedTopic
findIn r b tss = let filteredtss = filter (\(Tuple s _) -> s.room == show r && s.block == show b) tss
                 in case filteredtss of
                  [] -> Nothing
                  [(Tuple _ t)] -> Just t
                  _ -> Nothing

makeGrid :: SanitizedAppState -> [[Maybe SanitizedTopic]]
makeGrid as' = (\r -> (\b -> findIn r b as'.timeslots ) <$> as'.blocks ) <$> as'.rooms

foreign import renderMenu
"""function renderMenu(topicTypes){
  return function(){
    React.render(
      React.createElement(Menu, {topicTypes: topicTypes}),
      document.getElementById('menu')
      );
  }
}
""" :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopics
"""function renderTopics(topicsAndSelected){
  return function(){
    React.render(
      React.createElement(Topics, {topicsAndSelected: topicsAndSelected}),
      document.getElementById('topics')
      )
    }
  }
  """ :: forall eff. Tuple [SanitizedTopic] (Maybe SanitizedTopic) -> Eff( dom::DOM | eff ) Unit

foreign import renderGrid
"""
function renderGrid(rooms){
  return function(blocks){
      return function(grid){
        return function(){
        React.render(
          React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
          document.getElementById('grid')
        );
      }
    }
  }
}

""" :: forall eff. [Room] -> [Block] -> [[Maybe SanitizedTopic]] -> Eff( dom::DOM | eff ) Unit

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = do
  let as' = sanitizeAppState as
  renderTopics $ Tuple as'.topics as'.selectedTopic
  renderGrid as'.rooms as'.blocks (makeGrid as')

module Render.Main where

import Render.Types
import Data.Array
import Data.Maybe
import qualified Data.Map as M
import Data.Tuple
import Control.Monad.Eff

import DOM

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = as { timeslots = M.insert s t as.timeslots }

removeTimeslot :: Slot -> AppState -> AppState
removeTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

removeTopic :: Topic -> AppState -> AppState
removeTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

selectTopic :: Topic -> AppState -> AppState
selectTopic topic as = as { selectedTopic = Just topic }

unselectTopic :: AppState -> AppState
unselectTopic as = as { selectedTopic = Nothing :: Maybe Topic }

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = t { typ = show t.typ }

sanitizeSlot :: Slot -> SanitizedSlot
sanitizeSlot (Slot s) = { room  : show s.room
                        , block : show s.block
                        }

sanitizeTimeslot :: Timeslot -> SanitizedTimeslot
sanitizeTimeslot (Tuple s t) = Tuple (sanitizeSlot s) (sanitizeTopic t)

sanitizeAppState :: AppState -> SanitizedAppState
sanitizeAppState as = { topics     : sanitizeTopic    <$> as.topics
                      , rooms      : as.rooms
                      , blocks     : as.blocks
                      , slots      : sanitizeSlot     <$> as.slots
                      , timeslots  : sanitizeTimeslot <$> (M.toList as.timeslots)
                      , selectedTopic   : sanitizeTopic    <$> as.selectedTopic
                      }

findIn :: Room -> Block -> [SanitizedTimeslot] -> Maybe SanitizedTopic
findIn r b tss = let filteredtss = filter (\(Tuple s _) -> s.room == show r && s.block == show b) tss
                 in case filteredtss of
                  [] -> Nothing
                  [(Tuple _ t)] -> Just t
                  _ -> Nothing

makeGrid :: SanitizedAppState -> [[Maybe SanitizedTopic]]
makeGrid as' = (\r -> (\b -> findIn r b as'.timeslots ) <$> as'.blocks ) <$> as'.rooms

foreign import renderMenu
"""function renderMenu(topicTypes){
  return function(){
    React.render(
      React.createElement(Menu, {topicTypes: topicTypes}),
      document.getElementById('menu')
      );
  }
}
""" :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopics
"""function renderTopics(topicsAndSelected){
  return function(){
    React.render(
      React.createElement(Topics, {topicsAndSelected: topicsAndSelected}),
      document.getElementById('topics')
      )
    }
  }
  """ :: forall eff. Tuple [SanitizedTopic] (Maybe SanitizedTopic) -> Eff( dom::DOM | eff ) Unit

foreign import renderGrid
"""
function renderGrid(rooms){
  return function(blocks){
      return function(grid){
        return function(){
        React.render(
          React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
          document.getElementById('grid')
        );
      }
    }
  }
}

""" :: forall eff. [Room] -> [Block] -> [[Maybe SanitizedTopic]] -> Eff( dom::DOM | eff ) Unit

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = do
  let as' = sanitizeAppState as
  renderTopics $ Tuple as'.topics as'.selectedTopic
  renderGrid as'.rooms as'.blocks (makeGrid as')


remove ado for pulp

remove ado for pulp

module Simple.JSON
( E
, readJSON
, readJSON'
, readJSON_
, writeJSON
, write
, read
, read'
, read_
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), hush)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Read a JSON string to a type `a` while returning `Nothing` is the parsing
-- | failed.
readJSON_ ::  forall a
   . ReadForeign a
  => String
  -> Maybe a
readJSON_ = hush <<< readJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

-- | Read a Foreign value to a type
read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

-- | Read a value of any type as Foreign to a type
readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

-- | Read a Foreign value to a type, as a Maybe of type
read_ :: forall a
   . ReadForeign a
  => Foreign
  -> Maybe a
read_ = hush <<< read

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = (compose <$> first) `exceptTApply` rest
    where
      first = do
        value <- withExcept' (readImpl =<< readProp name obj)
        pure $ Builder.insert nameP value
      rest = getFields tailP obj
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
exceptTApply fun a = ExceptT $ applyEither
  <$> runExceptT fun
  <*> runExceptT a

applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
applyEither (Left e) (Right _) = Left e
applyEither (Left e1) (Left e2) = Left (e1 <> e2)
applyEither (Right _) (Left e) = Left e
applyEither (Right fun) (Right a) = Right (fun a)

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }

module Simple.JSON
( E
, readJSON
, readJSON'
, readJSON_
, writeJSON
, write
, read
, read'
, read_
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), hush)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Read a JSON string to a type `a` while returning `Nothing` is the parsing
-- | failed.
readJSON_ ::  forall a
   . ReadForeign a
  => String
  -> Maybe a
readJSON_ = hush <<< readJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

-- | Read a Foreign value to a type
read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

-- | Read a value of any type as Foreign to a type
readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

-- | Read a Foreign value to a type, as a Maybe of type
read_ :: forall a
   . ReadForeign a
  => Foreign
  -> Maybe a
read_ = hush <<< read

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = (compose <$> first) `exceptTApply` rest
    where
      first = do
        value <- withExcept' (readImpl =<< readProp name obj)
        pure $ Builder.insert nameP value
      rest = getFields tailP obj
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
exceptTApply fun a = ExceptT $ ado
  fun' :: Either e (a -> b) <- runExceptT fun
  a' :: (Either e a) <- runExceptT a
  in applyEither fun' a'

applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
applyEither (Left e) (Right _) = Left e
applyEither (Left e1) (Left e2) = Left (e1 <> e2)
applyEither (Right _) (Left e) = Left e
applyEither (Right fun) (Right a) = Right (fun a)

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }