Move to active card index

Move to active card index

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component
  ( initialState
  , render
  , eval
  , peek
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.UI.Browser (setHref, newTab)

import Data.Array as Array
import Data.Lens ((.~), (%~), (^?), (?~), _Left, _Just, is)
import Data.List as L

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils (raise', sendAfter', subscribeToBus')
import Halogen.HTML.Indexed as HH

import SlamData.Analytics as SA
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.Guide as Guide
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common.EvalQuery as CEQ
import SlamData.Workspace.Card.Component (CardQueryP, CardQuery(..), InnerCardQuery, AnyCardQuery)
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Next.Component.Query as Next
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, ChildQuery, ChildSlot, cpDialog, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (QueryP, Query(..), DeckAction(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckPath (deckPath, deckPath')
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Dialog.Share.Model (SharingInput)
import SlamData.Workspace.Deck.Model as Model
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (censor)
import Utils.DOM (elementEq)
import Utils.LocalStorage as LocalStorage

initialState ∷ DeckId → DCS.StateP
initialState = opaqueState ∘ DCS.initialDeck

render ∷ DeckOptions → (DeckOptions → DeckComponent) → DCS.State → DeckHTML
render opts deckComponent st =
  -- HACK: required so that nested finalizers get run. Since this is run inside
  -- of a separate runUI instance with Deck.Component.Nested, they will not
  -- get invoked by normal machinery. -nf
  if st.finalized
  then HH.div_ []
  else case st.stateMode of
    Error err → DCR.renderError err
    _ → DCR.renderDeck opts deckComponent st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.liftH $ H.liftH Wiring.expose
    mb ← subscribeToBus' (H.action ∘ HandleMessage) bus.decks
    H.modify $ DCS._breakers .~ [mb]
    when (L.null opts.cursor) do
      eb ← subscribeToBus' (H.action ∘ HandleError) bus.globalError
      H.modify $ DCS._breakers %~ (Array.cons eb)
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardGuide next → do
    H.modify (DCS._presentAccessNextActionCardGuide .~ true) $> next
  HideAccessNextActionCardGuide next →
    dismissAccessNextActionCardGuide $> next
  Finish next → do
    H.modify _ { finalized = true }
    H.gets _.breakers >>= traverse_ (H.fromAff ∘ EventLoop.break')
    pure next
  ExploreFile res next → do
    -- FIXME
    pure next
  Publish next → do
    { path } ← H.liftH $ H.liftH Wiring.expose
    deckPath ← deckPath' path <$> H.gets _.id
    H.fromEff ∘ newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    updateBackSide opts
    H.modify
      $ DCS._displayMode %~ case _ of
        DCS.Normal → DCS.Backside
        _ → DCS.Normal
    presentFlipGuideFirstTime
    pure next
  GrabDeck _ next →
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    { path, accessType, varMaps } ← H.liftH $ H.liftH Wiring.expose
    st ← H.get
    navigate $ WorkspaceRoute path (Just st.id) (WA.Load accessType) varMaps
    pure next
  ZoomOut next → do
    { path, accessType, varMaps } ← H.liftH $ H.liftH Wiring.expose
    st ← H.get
    case st.parent of
      Just (Tuple deckId _) → do
        navigate $ WorkspaceRoute path (Just deckId) (WA.Load accessType) varMaps
      Nothing →
        void $ H.fromEff $ setHref $ parentURL $ Left path
    pure next
  StartSliding mouseEvent gDef next → do
    H.gets _.deckElement >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      H.modify (DCS._cardElementWidth ?~ width)
      Slider.startSliding mouseEvent gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    for_ st.activeCardIndex \oldIndex →
      for_ (DCS.cardCoordFromIndex oldIndex st) \coord →
        void $ queryCardEval coord $ H.action CQ.DeactivateCard
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState
    when (DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)) do
      dismissAccessNextActionCardGuide
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  SetCardElement element next → do
    H.modify _ { deckElement = element }
    pure next
  StopSliderTransition next → do
    sliderTransition ← H.gets _.sliderTransition
    when sliderTransition $
      H.modify $ DCS._sliderTransition .~ false
    pure next
  DoAction _ next → pure next
  Focus next → do
    st ← H.get
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      { bus } ← H.liftH $ H.liftH Wiring.expose
      H.fromAff $ Bus.write (DeckFocused st.id) bus.decks
      presentAccessNextActionCardGuideAfterDelay
    pure next
  -- Isn't always evaluated when deck looses focus
  Defocus ev next → do
    st ← H.get
    isFrame ← H.fromEff $ elementEq ev.target ev.currentTarget
    when (st.focused && isFrame) $
      for_ (L.last opts.cursor) \rootId → do
        { bus } ← H.liftH $ H.liftH Wiring.expose
        H.fromAff $ Bus.write (DeckFocused rootId) bus.decks
    H.modify (DCS._presentAccessNextActionCardGuide .~ false)
    pure next
  HandleEval msg next →
    handleEval msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (st.id ≡ focusedDeckId && not st.focused) $
          H.modify (DCS._focused .~ true)
        when (st.id ≠ focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next
  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  DismissedCardGuide next → do
    -- FIXME
    pure next
  GetActiveCoord k → do
    active ← H.gets DCS.activeCard
    pure (k (censor ∘ map _.coord =<< active))
  where
  getBoundingClientWidth =
    H.fromEff ∘ map _.width ∘ getBoundingClientRect

peek ∷ ∀ a. DeckOptions → H.ChildF ChildSlot ChildQuery a → DeckDSL Unit
peek opts (H.ChildF s q) =
  (peekCards ⊹ (\_ _ → pure unit) $ s)
   ⨁ peekBackSide opts
   ⨁ (peekDialog opts ⨁ (const $ pure unit))
   ⨁ peekNextAction
   ⨁ (const $ pure unit)
   ⨁ (const $ pure unit)
   $ q

peekDialog ∷ ∀ a. DeckOptions → Dialog.Query a → DeckDSL Unit
peekDialog _ (Dialog.Show _ _) = do
  H.modify (DCS._displayMode .~ DCS.Dialog)
peekDialog _ (Dialog.Dismiss _) =
  H.modify (DCS._displayMode .~ DCS.Backside)
peekDialog _ (Dialog.FlipToFront _) =
  H.modify (DCS._displayMode .~ DCS.Normal)
peekDialog opts (Dialog.SetDeckName name _) =
  H.modify ((DCS._displayMode .~ DCS.Normal) ∘ (DCS._name .~ name))
peekDialog _ (Dialog.Confirm d b _) = do
  H.modify (DCS._displayMode .~ DCS.Backside)
  case d of
    Dialog.DeleteDeck | b → raise' $ H.action $ DoAction DeleteDeck
    _ → pure unit

peekBackSide ∷ ∀ a. DeckOptions → Back.Query a → DeckDSL Unit
peekBackSide opts (Back.DoAction action _) = do
  { path } ← H.liftH $ H.liftH Wiring.expose
  case action of
    Back.Trash → do
      active ← H.gets DCS.activeCard
      for_ (join $ censor <$> active) \{ coord } → do
        removeCard coord
        H.modify
          $ (DCS._displayMode .~ DCS.Normal)
          ∘ (DCS._presentAccessNextActionCardGuide .~ false)
      void $ H.queryAll' cpCard $ left $ H.action UpdateDimensions
    Back.Rename → do
      name ← H.gets _.name
      showDialog $ Dialog.Rename name
    Back.Share → do
      sharingInput ← getSharingInput
      showDialog $ Dialog.Share sharingInput
    Back.Unshare → do
      sharingInput ← getSharingInput
      showDialog $ Dialog.Unshare sharingInput
    Back.Embed → do
      st ← H.get
      SA.track (SA.Embed st.id)
      -- FIXME
      sharingInput ← getSharingInput
      showDialog $ Dialog.Embed sharingInput mempty
    Back.Publish → do
      st ← H.get
      SA.track (SA.Publish st.id)
      -- FIXME
      sharingInput ← getSharingInput
      showDialog $ Dialog.Publish sharingInput mempty
    Back.DeleteDeck → do
      cards ← H.gets _.displayCards
      if Array.null cards
        then raise' $ H.action $ DoAction DeleteDeck
        else showDialog Dialog.DeleteDeck
    Back.Mirror → do
      H.modify $ DCS._displayMode .~ DCS.Normal
      raise' $ H.action $ DoAction Mirror
    Back.Wrap →
      raise' $ H.action $ DoAction Wrap
    Back.Unwrap →
      raise' $ H.action $ DoAction $ Unwrap
peekBackSide _ _ = pure unit

peekCards ∷ ∀ a. DeckId × CardId → CardQueryP a → DeckDSL Unit
peekCards cardId = const (pure unit) ⨁ peekCardInner cardId

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog dlg = do
  queryDialog $ H.action $ Dialog.Show dlg
  H.modify (DCS._displayMode .~ DCS.Dialog)

queryDialog ∷ Dialog.Query Unit → DeckDSL Unit
queryDialog q = H.query' cpDialog unit (left q) *> pure unit

queryCard ∷ ∀ a. DeckId × CardId → CQ.AnyCardQuery a → DeckDSL (Maybe a)
queryCard cid =
  H.query' cpCard cid
    ∘ right
    ∘ H.ChildF unit
    ∘ right

queryCardEval ∷ ∀ a. DeckId × CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid ∘ left

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveCard ∷ DeckDSL Unit
updateActiveCard = do
  st ← H.get
  case st.activeCardIndex of
    Nothing → H.modify $ DCS._activeCardIndex .~ Just (DCS.defaultActiveIndex st)
    Just _ → pure unit
  updateActiveState

updateActiveState ∷ DeckDSL Unit
updateActiveState = do
  st ← H.get
  { cache } ← H.liftH $ H.liftH Wiring.expose
  for_ st.activeCardIndex \cardIndex → do
    Cache.put st.id { cardIndex } cache.activeState
    for_ (DCS.cardCoordFromIndex cardIndex st) \coord →
      void $ queryCardEval coord $ H.action CQ.ActivateCard

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { cursor } = do
  st ← H.get
  let
    ty = join (censor <$> DCS.activeCard st)
    tys = Array.mapMaybe censor st.displayCards
  void $ H.query' cpBackSide unit $ H.action $ Back.UpdateCard ty tys

createCard ∷ CT.CardType → DeckDSL Unit
createCard = broadcast ∘ ED.AddCard

removeCard ∷ DeckId × CardId → DeckDSL Unit
removeCard = broadcast ∘ ED.RemoveCard

dismissedAccessNextActionCardGuideKey ∷ String
dismissedAccessNextActionCardGuideKey = "dismissedAccessNextActionCardGuide"

getDismissedAccessNextActionCardGuideBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardGuideBefore =
  H.liftH $ H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAccessNextActionCardGuideKey

storeDismissedAccessNextActionCardGuide ∷ DeckDSL Unit
storeDismissedAccessNextActionCardGuide =
  H.liftH $ H.liftH $ LocalStorage.setLocalStorage dismissedAccessNextActionCardGuideKey true

presentAccessNextActionCardGuideAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardGuideAfterDelay = do
  dismissedBefore ← getDismissedAccessNextActionCardGuideBefore
  focused ← H.gets _.focused
  when
    (not dismissedBefore && focused)
    do
      cancelPresentAccessNextActionCardGuide
      H.modify
        ∘ (DCS._presentAccessNextActionCardGuideCanceler .~ _)
        ∘ Just
        =<< (sendAfter' Config.addCardGuideDelay $ PresentAccessNextActionCardGuide unit)

cancelPresentAccessNextActionCardGuide ∷ DeckDSL Boolean
cancelPresentAccessNextActionCardGuide =
  H.fromAff ∘ maybe (pure false) (flip Aff.cancel $ Exception.error "Cancelled")
    =<< H.gets _.presentAccessNextActionCardGuideCanceler

dismissAccessNextActionCardGuide ∷ DeckDSL Unit
dismissAccessNextActionCardGuide =
  H.gets _.presentAccessNextActionCardGuide >>=
    flip when do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      storeDismissedAccessNextActionCardGuide

resetAccessNextActionCardGuideDelay ∷ DeckDSL Unit
resetAccessNextActionCardGuideDelay =
  cancelPresentAccessNextActionCardGuide
  >>= if _ then presentAccessNextActionCardGuideAfterDelay else pure unit

peekCardInner
  ∷ ∀ a
  . DeckId × CardId
  → H.ChildF Unit InnerCardQuery a
  → DeckDSL Unit
peekCardInner cardCoord = H.runChildF ⋙
  (peekCardEvalQuery cardCoord ⨁ peekAnyCard cardCoord)

peekCardEvalQuery ∷ ∀ a. DeckId × CardId → CEQ.CardEvalQuery a → DeckDSL Unit
peekCardEvalQuery cardCoord = case _ of
  CEQ.ZoomIn _ → raise' $ H.action ZoomIn
  _ → pure unit

peekAnyCard ∷ ∀ a. DeckId × CardId → AnyCardQuery a → DeckDSL Unit
peekAnyCard cardCoord _ =
  resetAccessNextActionCardGuideDelay

peekNextAction ∷ ∀ a. Next.Query a → DeckDSL Unit
peekNextAction q = do
  for_ (q ^? Next._AddCardType) createCard
  for_ (q ^? Next._PresentReason) $ uncurry presentReason

presentReason ∷ Port.Port → CT.CardType → DeckDSL Unit
presentReason input cardType =
  showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason cardType reason cardPaths

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = do
  st ← H.get
  { bus, value } ← H.liftH $ H.liftH $ P.getDeck' st.id
  breaker ← subscribeToBus' (H.action ∘ HandleEval) bus
  H.modify \s → s
    { stateMode = Ready
    , displayCards = [ Left DCS.PendingCard ]
    , breakers = Array.cons breaker s.breakers
    }
  Promise.wait value >>= case _ of
    Left err →
      H.modify _ { stateMode = Error "Error loading deck" }
    Right deck → do
      let
        coords = Model.cardCoords st.id deck
      case Array.head coords of
        Just coord → do
          H.modify $ DCS.fromModel
            { name: deck.name
            , parent: deck.parent
            , displayCards: [ Left DCS.PendingCard ]
            }
          H.fromAff $ Bus.write (ED.Force (opts.cursor × coord)) bus
        Nothing →
          H.modify $ DCS.fromModel
            { name: deck.name
            , parent: deck.parent
            , displayCards: [ Left (DCS.NextActionCard Port.Initial) ]
            }

handleEval ∷ ED.EvalMessage → DeckDSL Unit
handleEval = case _ of
  ED.Pending →
    H.modify (DCS.addMetaCard DCS.PendingCard)
  ED.Complete coords res → do
    st ← H.get
    mbCards ← getCardCells coords
    for_ mbCards \cards → void do
      let newDefs = makeDef <$> Array.zip coords cards
      queryNextAction $ H.action $ Next.UpdateInput res
      H.modify (updateDisplayCards newDefs res)
      updateActiveState
  _ →
    pure unit

  where
  getCardCells coords =
    H.liftH $ H.liftH $ sequence <$> traverse P.getCard coords

  makeDef (coord × c) =
    { coord, cardType: Card.modelCardType c.value.model.model }

  updateDisplayCards defs res st =
    let
      displayCards =
        case Array.uncons defs of
          Just { head, tail } →
            let
              realCards = Array.mapMaybe censor st.displayCards
              initCards = Array.takeWhile (not ∘ eq head.coord ∘ _.coord) realCards
              newCards = Array.cons head tail
              metaCard =
                pure $ Left case res of
                  Port.CardError str → DCS.ErrorCard str
                  _ → DCS.NextActionCard res
            in
              (Right <$> initCards <> newCards) <> metaCard
          Nothing →
            [ Left (DCS.NextActionCard Port.Initial) ]
      lastIndex =
        Array.length displayCards - 1
      activeCardIndex =
        case st.activeCardIndex, Array.last displayCards of
          Nothing, Nothing → 0
          Nothing, Just (Left (DCS.ErrorCard _)) → lastIndex
          Nothing, Just _ → lastIndex - 1
          Just ix, _ | ix > lastIndex → lastIndex
          Just ix, _ → ix
    in
      st { displayCards = displayCards
         , activeCardIndex = Just activeCardIndex
         }

getSharingInput ∷ DeckDSL SharingInput
getSharingInput = do
  -- FIXME
  { path } ← H.liftH $ H.liftH Wiring.expose
  deckId ← H.gets _.id
  pure { deckId, workspacePath: path, caches: L.Nil, sources: L.Nil }

updateCardSize ∷ DeckDSL Unit
updateCardSize = do
  H.queryAll' cpCard $ left $ H.action UpdateDimensions
  H.gets _.deckElement >>= traverse_ \el → do
    { width } ← H.fromEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  H.gets _.displayMode >>=
    case _ of
      DCS.Backside → do
        { bus } ← H.liftH $ H.liftH Wiring.expose
        shouldPresentFlipGuide >>=
          if _
          then H.fromAff $ Bus.write Wiring.FlipGuide bus.stepByStep
          else pure unit
      _ → pure unit

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.liftH
    $ H.liftH
    $ either (const true) not <$> LocalStorage.getLocalStorage Guide.dismissedFlipGuideKey

queryRootDeckCard ∷ ∀ a. CardId → CQ.AnyCardQuery a → DeckDSL (Maybe a)
queryRootDeckCard cid query =
  flip queryCard query ∘ flip Tuple cid =<< H.gets _.id

broadcast ∷ ED.EvalMessage → DeckDSL Unit
broadcast msg = do
  st ← H.get
  { bus } ← H.liftH $ H.liftH $ P.getDeck' st.id
  H.fromAff $ Bus.write msg bus
  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.Deck.Component
  ( initialState
  , render
  , eval
  , peek
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.UI.Browser (setHref, newTab)

import Data.Array as Array
import Data.Lens ((.~), (%~), (^?), (?~), _Left, _Just, is)
import Data.List as L

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils (raise', sendAfter', subscribeToBus')
import Halogen.HTML.Indexed as HH

import SlamData.Analytics as SA
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.Guide as Guide
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common.EvalQuery as CEQ
import SlamData.Workspace.Card.Component (CardQueryP, CardQuery(..), InnerCardQuery, AnyCardQuery)
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Next.Component.Query as Next
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, ChildQuery, ChildSlot, cpDialog, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (QueryP, Query(..), DeckAction(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckPath (deckPath, deckPath')
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Dialog.Share.Model (SharingInput)
import SlamData.Workspace.Deck.Model as Model
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (censor)
import Utils.DOM (elementEq)
import Utils.LocalStorage as LocalStorage

initialState ∷ DeckId → DCS.StateP
initialState = opaqueState ∘ DCS.initialDeck

render ∷ DeckOptions → (DeckOptions → DeckComponent) → DCS.State → DeckHTML
render opts deckComponent st =
  -- HACK: required so that nested finalizers get run. Since this is run inside
  -- of a separate runUI instance with Deck.Component.Nested, they will not
  -- get invoked by normal machinery. -nf
  if st.finalized
  then HH.div_ []
  else case st.stateMode of
    Error err → DCR.renderError err
    _ → DCR.renderDeck opts deckComponent st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.liftH $ H.liftH Wiring.expose
    mb ← subscribeToBus' (H.action ∘ HandleMessage) bus.decks
    H.modify $ DCS._breakers .~ [mb]
    when (L.null opts.cursor) do
      eb ← subscribeToBus' (H.action ∘ HandleError) bus.globalError
      H.modify $ DCS._breakers %~ (Array.cons eb)
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardGuide next → do
    H.modify (DCS._presentAccessNextActionCardGuide .~ true) $> next
  HideAccessNextActionCardGuide next →
    dismissAccessNextActionCardGuide $> next
  Finish next → do
    H.modify _ { finalized = true }
    H.gets _.breakers >>= traverse_ (H.fromAff ∘ EventLoop.break')
    pure next
  ExploreFile res next → do
    -- FIXME
    pure next
  Publish next → do
    { path } ← H.liftH $ H.liftH Wiring.expose
    deckPath ← deckPath' path <$> H.gets _.id
    H.fromEff ∘ newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    updateBackSide opts
    H.modify
      $ DCS._displayMode %~ case _ of
        DCS.Normal → DCS.Backside
        _ → DCS.Normal
    presentFlipGuideFirstTime
    pure next
  GrabDeck _ next →
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    { path, accessType, varMaps } ← H.liftH $ H.liftH Wiring.expose
    st ← H.get
    navigate $ WorkspaceRoute path (Just st.id) (WA.Load accessType) varMaps
    pure next
  ZoomOut next → do
    { path, accessType, varMaps } ← H.liftH $ H.liftH Wiring.expose
    st ← H.get
    case st.parent of
      Just (Tuple deckId _) → do
        navigate $ WorkspaceRoute path (Just deckId) (WA.Load accessType) varMaps
      Nothing →
        void $ H.fromEff $ setHref $ parentURL $ Left path
    pure next
  StartSliding mouseEvent gDef next → do
    H.gets _.deckElement >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      H.modify (DCS._cardElementWidth ?~ width)
      Slider.startSliding mouseEvent gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    for_ st.activeCardIndex \oldIndex →
      for_ (DCS.cardCoordFromIndex oldIndex st) \coord →
        void $ queryCardEval coord $ H.action CQ.DeactivateCard
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState
    when (DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)) do
      dismissAccessNextActionCardGuide
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  SetCardElement element next → do
    H.modify _ { deckElement = element }
    pure next
  StopSliderTransition next → do
    sliderTransition ← H.gets _.sliderTransition
    when sliderTransition $
      H.modify $ DCS._sliderTransition .~ false
    pure next
  DoAction _ next → pure next
  Focus next → do
    st ← H.get
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      { bus } ← H.liftH $ H.liftH Wiring.expose
      H.fromAff $ Bus.write (DeckFocused st.id) bus.decks
      presentAccessNextActionCardGuideAfterDelay
    pure next
  -- Isn't always evaluated when deck looses focus
  Defocus ev next → do
    st ← H.get
    isFrame ← H.fromEff $ elementEq ev.target ev.currentTarget
    when (st.focused && isFrame) $
      for_ (L.last opts.cursor) \rootId → do
        { bus } ← H.liftH $ H.liftH Wiring.expose
        H.fromAff $ Bus.write (DeckFocused rootId) bus.decks
    H.modify (DCS._presentAccessNextActionCardGuide .~ false)
    pure next
  HandleEval msg next →
    handleEval msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (st.id ≡ focusedDeckId && not st.focused) $
          H.modify (DCS._focused .~ true)
        when (st.id ≠ focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next
  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  DismissedCardGuide next → do
    -- FIXME
    pure next
  GetActiveCoord k → do
    active ← H.gets DCS.activeCard
    pure (k (censor ∘ map _.coord =<< active))
  where
  getBoundingClientWidth =
    H.fromEff ∘ map _.width ∘ getBoundingClientRect

peek ∷ ∀ a. DeckOptions → H.ChildF ChildSlot ChildQuery a → DeckDSL Unit
peek opts (H.ChildF s q) =
  (peekCards ⊹ (\_ _ → pure unit) $ s)
   ⨁ peekBackSide opts
   ⨁ (peekDialog opts ⨁ (const $ pure unit))
   ⨁ peekNextAction
   ⨁ (const $ pure unit)
   ⨁ (const $ pure unit)
   $ q

peekDialog ∷ ∀ a. DeckOptions → Dialog.Query a → DeckDSL Unit
peekDialog _ (Dialog.Show _ _) = do
  H.modify (DCS._displayMode .~ DCS.Dialog)
peekDialog _ (Dialog.Dismiss _) =
  H.modify (DCS._displayMode .~ DCS.Backside)
peekDialog _ (Dialog.FlipToFront _) =
  H.modify (DCS._displayMode .~ DCS.Normal)
peekDialog opts (Dialog.SetDeckName name _) =
  H.modify ((DCS._displayMode .~ DCS.Normal) ∘ (DCS._name .~ name))
peekDialog _ (Dialog.Confirm d b _) = do
  H.modify (DCS._displayMode .~ DCS.Backside)
  case d of
    Dialog.DeleteDeck | b → raise' $ H.action $ DoAction DeleteDeck
    _ → pure unit

peekBackSide ∷ ∀ a. DeckOptions → Back.Query a → DeckDSL Unit
peekBackSide opts (Back.DoAction action _) = do
  { path } ← H.liftH $ H.liftH Wiring.expose
  case action of
    Back.Trash → do
      active ← H.gets DCS.activeCard
      for_ (join $ censor <$> active) \{ coord } → do
        removeCard coord
        H.modify
          $ (DCS._displayMode .~ DCS.Normal)
          ∘ (DCS._presentAccessNextActionCardGuide .~ false)
      void $ H.queryAll' cpCard $ left $ H.action UpdateDimensions
    Back.Rename → do
      name ← H.gets _.name
      showDialog $ Dialog.Rename name
    Back.Share → do
      sharingInput ← getSharingInput
      showDialog $ Dialog.Share sharingInput
    Back.Unshare → do
      sharingInput ← getSharingInput
      showDialog $ Dialog.Unshare sharingInput
    Back.Embed → do
      st ← H.get
      SA.track (SA.Embed st.id)
      -- FIXME
      sharingInput ← getSharingInput
      showDialog $ Dialog.Embed sharingInput mempty
    Back.Publish → do
      st ← H.get
      SA.track (SA.Publish st.id)
      -- FIXME
      sharingInput ← getSharingInput
      showDialog $ Dialog.Publish sharingInput mempty
    Back.DeleteDeck → do
      cards ← H.gets _.displayCards
      if Array.null cards
        then raise' $ H.action $ DoAction DeleteDeck
        else showDialog Dialog.DeleteDeck
    Back.Mirror → do
      H.modify $ DCS._displayMode .~ DCS.Normal
      raise' $ H.action $ DoAction Mirror
    Back.Wrap →
      raise' $ H.action $ DoAction Wrap
    Back.Unwrap →
      raise' $ H.action $ DoAction $ Unwrap
peekBackSide _ _ = pure unit

peekCards ∷ ∀ a. DeckId × CardId → CardQueryP a → DeckDSL Unit
peekCards cardId = const (pure unit) ⨁ peekCardInner cardId

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog dlg = do
  queryDialog $ H.action $ Dialog.Show dlg
  H.modify (DCS._displayMode .~ DCS.Dialog)

queryDialog ∷ Dialog.Query Unit → DeckDSL Unit
queryDialog q = H.query' cpDialog unit (left q) *> pure unit

queryCard ∷ ∀ a. DeckId × CardId → CQ.AnyCardQuery a → DeckDSL (Maybe a)
queryCard cid =
  H.query' cpCard cid
    ∘ right
    ∘ H.ChildF unit
    ∘ right

queryCardEval ∷ ∀ a. DeckId × CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid ∘ left

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveCard ∷ DeckDSL Unit
updateActiveCard = do
  st ← H.get
  case st.activeCardIndex of
    Nothing → H.modify $ DCS._activeCardIndex .~ Just (DCS.defaultActiveIndex st)
    Just _ → pure unit
  updateActiveState

updateActiveState ∷ DeckDSL Unit
updateActiveState = do
  st ← H.get
  { cache } ← H.liftH $ H.liftH Wiring.expose
  for_ st.activeCardIndex \cardIndex → do
    Cache.put st.id { cardIndex } cache.activeState
    for_ (DCS.cardCoordFromIndex cardIndex st) \coord →
      void $ queryCardEval coord $ H.action CQ.ActivateCard

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { cursor } = do
  st ← H.get
  let
    ty = join (censor <$> DCS.activeCard st)
    tys = Array.mapMaybe censor st.displayCards
  void $ H.query' cpBackSide unit $ H.action $ Back.UpdateCard ty tys

createCard ∷ CT.CardType → DeckDSL Unit
createCard = broadcast ∘ ED.AddCard

removeCard ∷ DeckId × CardId → DeckDSL Unit
removeCard = broadcast ∘ ED.RemoveCard

dismissedAccessNextActionCardGuideKey ∷ String
dismissedAccessNextActionCardGuideKey = "dismissedAccessNextActionCardGuide"

getDismissedAccessNextActionCardGuideBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardGuideBefore =
  H.liftH $ H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAccessNextActionCardGuideKey

storeDismissedAccessNextActionCardGuide ∷ DeckDSL Unit
storeDismissedAccessNextActionCardGuide =
  H.liftH $ H.liftH $ LocalStorage.setLocalStorage dismissedAccessNextActionCardGuideKey true

presentAccessNextActionCardGuideAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardGuideAfterDelay = do
  dismissedBefore ← getDismissedAccessNextActionCardGuideBefore
  focused ← H.gets _.focused
  when
    (not dismissedBefore && focused)
    do
      cancelPresentAccessNextActionCardGuide
      H.modify
        ∘ (DCS._presentAccessNextActionCardGuideCanceler .~ _)
        ∘ Just
        =<< (sendAfter' Config.addCardGuideDelay $ PresentAccessNextActionCardGuide unit)

cancelPresentAccessNextActionCardGuide ∷ DeckDSL Boolean
cancelPresentAccessNextActionCardGuide =
  H.fromAff ∘ maybe (pure false) (flip Aff.cancel $ Exception.error "Cancelled")
    =<< H.gets _.presentAccessNextActionCardGuideCanceler

dismissAccessNextActionCardGuide ∷ DeckDSL Unit
dismissAccessNextActionCardGuide =
  H.gets _.presentAccessNextActionCardGuide >>=
    flip when do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      storeDismissedAccessNextActionCardGuide

resetAccessNextActionCardGuideDelay ∷ DeckDSL Unit
resetAccessNextActionCardGuideDelay =
  cancelPresentAccessNextActionCardGuide
  >>= if _ then presentAccessNextActionCardGuideAfterDelay else pure unit

peekCardInner
  ∷ ∀ a
  . DeckId × CardId
  → H.ChildF Unit InnerCardQuery a
  → DeckDSL Unit
peekCardInner cardCoord = H.runChildF ⋙
  (peekCardEvalQuery cardCoord ⨁ peekAnyCard cardCoord)

peekCardEvalQuery ∷ ∀ a. DeckId × CardId → CEQ.CardEvalQuery a → DeckDSL Unit
peekCardEvalQuery cardCoord = case _ of
  CEQ.ZoomIn _ → raise' $ H.action ZoomIn
  _ → pure unit

peekAnyCard ∷ ∀ a. DeckId × CardId → AnyCardQuery a → DeckDSL Unit
peekAnyCard cardCoord _ =
  resetAccessNextActionCardGuideDelay

peekNextAction ∷ ∀ a. Next.Query a → DeckDSL Unit
peekNextAction q = do
  for_ (q ^? Next._AddCardType) createCard
  for_ (q ^? Next._PresentReason) $ uncurry presentReason

presentReason ∷ Port.Port → CT.CardType → DeckDSL Unit
presentReason input cardType =
  showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason cardType reason cardPaths

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = do
  st ← H.get
  { bus, value } ← H.liftH $ H.liftH $ P.getDeck' st.id
  breaker ← subscribeToBus' (H.action ∘ HandleEval) bus
  H.modify \s → s
    { stateMode = Ready
    , displayCards = [ Left DCS.PendingCard ]
    , breakers = Array.cons breaker s.breakers
    }
  Promise.wait value >>= case _ of
    Left err →
      H.modify _ { stateMode = Error "Error loading deck" }
    Right deck → do
      let
        coords = Model.cardCoords st.id deck
      case Array.head coords of
        Just coord → do
          H.modify $ DCS.fromModel
            { name: deck.name
            , parent: deck.parent
            , displayCards: [ Left DCS.PendingCard ]
            }
          H.fromAff $ Bus.write (ED.Force (opts.cursor × coord)) bus
        Nothing →
          H.modify $ DCS.fromModel
            { name: deck.name
            , parent: deck.parent
            , displayCards: [ Left (DCS.NextActionCard Port.Initial) ]
            }

handleEval ∷ ED.EvalMessage → DeckDSL Unit
handleEval = case _ of
  ED.Pending →
    H.modify (DCS.addMetaCard DCS.PendingCard)
  ED.Complete coords res → do
    st ← H.get
    mbCards ← getCardCells coords
    for_ mbCards \cards → void do
      let newDefs = makeDef <$> Array.zip coords cards
      queryNextAction $ H.action $ Next.UpdateInput res
      H.modify (updateDisplayCards newDefs res)
  _ →
    pure unit

  where
  getCardCells coords =
    H.liftH $ H.liftH $ sequence <$> traverse P.getCard coords

  makeDef (coord × c) =
    { coord, cardType: Card.modelCardType c.value.model.model }

  updateDisplayCards defs res st =
    case Array.uncons defs of
      Just { head, tail } →
        let
          realCards = Array.mapMaybe censor st.displayCards
          initCards = Array.takeWhile (not ∘ eq head.coord ∘ _.coord) realCards
          newCards = Array.cons head tail
          metaCard =
            pure $ Left case res of
              Port.CardError str → DCS.ErrorCard str
              _ → DCS.NextActionCard res
        in
          st { displayCards = (Right <$> initCards <> newCards) <> metaCard }
      Nothing →
        st { displayCards = [ Left (DCS.NextActionCard Port.Initial) ] }

getSharingInput ∷ DeckDSL SharingInput
getSharingInput = do
  -- FIXME
  { path } ← H.liftH $ H.liftH Wiring.expose
  deckId ← H.gets _.id
  pure { deckId, workspacePath: path, caches: L.Nil, sources: L.Nil }

updateCardSize ∷ DeckDSL Unit
updateCardSize = do
  H.queryAll' cpCard $ left $ H.action UpdateDimensions
  H.gets _.deckElement >>= traverse_ \el → do
    { width } ← H.fromEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  H.gets _.displayMode >>=
    case _ of
      DCS.Backside → do
        { bus } ← H.liftH $ H.liftH Wiring.expose
        shouldPresentFlipGuide >>=
          if _
          then H.fromAff $ Bus.write Wiring.FlipGuide bus.stepByStep
          else pure unit
      _ → pure unit

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.liftH
    $ H.liftH
    $ either (const true) not <$> LocalStorage.getLocalStorage Guide.dismissedFlipGuideKey

queryRootDeckCard ∷ ∀ a. CardId → CQ.AnyCardQuery a → DeckDSL (Maybe a)
queryRootDeckCard cid query =
  flip queryCard query ∘ flip Tuple cid =<< H.gets _.id

broadcast ∷ ED.EvalMessage → DeckDSL Unit
broadcast msg = do
  st ← H.get
  { bus } ← H.liftH $ H.liftH $ P.getDeck' st.id
  H.fromAff $ Bus.write msg bus
  pure unit


[CSE-159] Hide Since row

[CSE-159] Hide Since row

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    ) where

import Prelude

import Data.Array (length, null, slice)
import Data.DateTime (diff)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Monoid (mempty)
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.String (take)
import Data.Time.Duration (Milliseconds)

import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blEpochSlotNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cBlockLead, cSize) as I18nL
import Explorer.Lenses.State (_PageNumber, blocksViewState, blsViewPagination, blsViewPaginationEditable, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CBlockEntries, CCurrency(..), PageNumber(..), State)
import Explorer.Util.Factory (mkEpochIndex)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnLead, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, noData, paginationView)

import Network.RemoteData (RemoteData(..), withDefault)

import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeEpoch, cbeSlot, cbeBlockLead, cbeSize, cbeTotalSent, cbeTxNum)

import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.DOM.Events (onClick) as P
import Pux.Renderer.React (dangerouslySetInnerHTML) as P

import Text.Smolder.HTML (a, div, span, h3, p) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!))

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.HTML Action
blocksView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-blocks"
          $ S.div ! S.className "explorer-blocks__wrapper"
                  $ S.div ! S.className "explorer-blocks__container" $ do
                        S.h3  ! S.className "headline"
                              $ S.text (( translate (I18nL.common <<< I18nL.cEpoch) lang')
                                          <> " / " <>
                                          (translate (I18nL.common <<< I18nL.cSlot) lang')
                                        )
                        case state ^. currentBlocksResult of
                            NotAsked  -> emptyBlocksView ""
                            Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                            Failure _ -> failureView lang'
                            Success blocks ->
                                let paginationViewProps =
                                        { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                        , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                        , minPage: PageNumber minPagination
                                        , maxPage: PageNumber $ getMaxPaginationNumber (length blocks) maxBlockRows
                                        , changePageAction: BlocksPaginateBlocks
                                        , editable: state ^. (viewStates <<< blocksViewState <<< blsViewPaginationEditable)
                                        , editableAction: BlocksEditBlocksPageNumber
                                        , invalidPageAction: BlocksInvalidBlocksPageNumber
                                        , disabled: false
                                        }
                                in
                                S.div do
                                    blocksHeaderView blocks lang'
                                    S.div ! S.className CSS.blocksBody
                                          $ for_ (currentBlocks state) (blockRow state)
                                    S.div ! S.className CSS.blocksFooter
                                          $ paginationView paginationViewProps

emptyBlocksView :: String -> P.HTML Action
emptyBlocksView message =
    S.div ! S.className "blocks-message"
          ! P.dangerouslySetInnerHTML message
          $ mempty

failureView :: Language -> P.HTML Action
failureView lang =
    S.div do
        S.p ! S.className CSS.blocksFailed
            $ S.text (translate (I18nL.block <<< I18nL.blEpochSlotNotFound) lang)
        S.a ! S.href (toUrl Dashboard)
            #! P.onClick (Navigate $ toUrl Dashboard)
            ! S.className "btn-back"
            $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang)

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = withDefault [] $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination <<< _PageNumber)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.HTML Action
blockRow state (CBlockEntry entry) =
    S.div ! S.className CSS.blocksBodyRow
          ! P.key ((show $ entry ^. cbeEpoch) <> "-" <> (show $ entry ^. cbeSlot)) $ do
          blockColumn { label: show $ entry ^. cbeEpoch
                      , mRoute: Just <<< Epoch <<< mkEpochIndex $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      , mCurrency: Nothing
                      }
          blockColumn { label: show $ entry ^. cbeSlot
                      , mRoute: Just <<< Block $ entry ^. cbeBlkHash
                      , clazz: CSS.blocksColumnSlot
                      , mCurrency: Nothing
                      }
          --blockColumn { label: labelAge
          --            , mRoute: Nothing
          --            , clazz: CSS.blocksColumnAge
          --            , mCurrency: Nothing
          --            }
          blockColumn { label: show $ entry ^. cbeTxNum
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnTxs
                      , mCurrency: Nothing
                      }
          blockColumn { label: formatADA (entry ^. cbeTotalSent) $ state ^. lang
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnTotalSent
                      , mCurrency: Just ADA
                      }
          blockColumn { label: labelBlockLead
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnLead
                      , mCurrency: Nothing
                      }
          blockColumn { label: show $ entry ^. cbeSize
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnSize
                      , mCurrency: Nothing
                      }
    where
        language = state ^. lang
        labelAge = fromMaybe noData $ (prettyDuration language :: Milliseconds -> String) <<< diff state.now <$> (nominalDiffTimeToDateTime  =<< entry.cbeTimeIssued)
        labelBlockLead = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ take 7 <$> (entry ^. cbeBlockLead)

type BlockColumnProps =
    { label :: String
    , clazz :: String
    , mCurrency :: Maybe CCurrency
    , mRoute :: Maybe Route
    }

blockColumn :: BlockColumnProps -> P.HTML Action
blockColumn props =
    let tag = case props.mRoute of
                  Just route ->
                      S.a ! S.href (toUrl route)
                          #! P.onClick (Navigate $ toUrl route)
                  Nothing ->
                      S.div
    in
    tag ! S.className props.clazz
        $ if isJust props.mCurrency
              then S.span ! S.className (currencyCSSClass props.mCurrency)
                          $ S.text props.label
              else S.text props.label

type BlocksHeaderProps =
    { id :: String
    , label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { id: "1"
      , label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    --, { id: "2"
    --  , label: translate (I18nL.common <<< I18nL.cAge) lang
    --  , clazz: CSS.blocksColumnAge
    --  }
    , { id: "3"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { id: "4"
      , label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
    , { id: "5"
      , label: translate (I18nL.common <<< I18nL.cBlockLead) lang
      , clazz: CSS.blocksColumnLead
      }
    , { id: "6"
      , label: translate (I18nL.common <<< I18nL.cSize) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.HTML Action
blocksHeaderView blocks lang =
    S.div ! S.className (CSS.blocksHeader <> if null blocks then " hide" else "")
          $ for_ (mkBlocksHeaderProps lang) blockHeaderItemView

blockHeaderItemView :: BlocksHeaderProps -> P.HTML Action
blockHeaderItemView props =
    S.div ! S.className props.clazz
          ! P.key props.id
          $ S.text props.label

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    ) where

import Prelude

import Data.Array (length, null, slice)
import Data.DateTime (diff)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Monoid (mempty)
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.String (take)
import Data.Time.Duration (Milliseconds)

import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blEpochSlotNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cBlockLead, cSize) as I18nL
import Explorer.Lenses.State (_PageNumber, blocksViewState, blsViewPagination, blsViewPaginationEditable, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CBlockEntries, CCurrency(..), PageNumber(..), State)
import Explorer.Util.Factory (mkEpochIndex)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnLead, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, noData, paginationView)

import Network.RemoteData (RemoteData(..), withDefault)

import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeEpoch, cbeSlot, cbeBlockLead, cbeSize, cbeTotalSent, cbeTxNum)

import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.DOM.Events (onClick) as P
import Pux.Renderer.React (dangerouslySetInnerHTML) as P

import Text.Smolder.HTML (a, div, span, h3, p) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!))

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.HTML Action
blocksView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-blocks"
          $ S.div ! S.className "explorer-blocks__wrapper"
                  $ S.div ! S.className "explorer-blocks__container" $ do
                        S.h3  ! S.className "headline"
                              $ S.text (( translate (I18nL.common <<< I18nL.cEpoch) lang')
                                          <> " / " <>
                                          (translate (I18nL.common <<< I18nL.cSlot) lang')
                                        )
                        case state ^. currentBlocksResult of
                            NotAsked  -> emptyBlocksView ""
                            Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                            Failure _ -> failureView lang'
                            Success blocks ->
                                let paginationViewProps =
                                        { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                        , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                        , minPage: PageNumber minPagination
                                        , maxPage: PageNumber $ getMaxPaginationNumber (length blocks) maxBlockRows
                                        , changePageAction: BlocksPaginateBlocks
                                        , editable: state ^. (viewStates <<< blocksViewState <<< blsViewPaginationEditable)
                                        , editableAction: BlocksEditBlocksPageNumber
                                        , invalidPageAction: BlocksInvalidBlocksPageNumber
                                        , disabled: false
                                        }
                                in
                                S.div do
                                    blocksHeaderView blocks lang'
                                    S.div ! S.className CSS.blocksBody
                                          $ for_ (currentBlocks state) (blockRow state)
                                    S.div ! S.className CSS.blocksFooter
                                          $ paginationView paginationViewProps

emptyBlocksView :: String -> P.HTML Action
emptyBlocksView message =
    S.div ! S.className "blocks-message"
          ! P.dangerouslySetInnerHTML message
          $ mempty

failureView :: Language -> P.HTML Action
failureView lang =
    S.div do
        S.p ! S.className CSS.blocksFailed
            $ S.text (translate (I18nL.block <<< I18nL.blEpochSlotNotFound) lang)
        S.a ! S.href (toUrl Dashboard)
            #! P.onClick (Navigate $ toUrl Dashboard)
            ! S.className "btn-back"
            $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang)

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = withDefault [] $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination <<< _PageNumber)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.HTML Action
blockRow state (CBlockEntry entry) =
    S.div ! S.className CSS.blocksBodyRow
          ! P.key ((show $ entry ^. cbeEpoch) <> "-" <> (show $ entry ^. cbeSlot)) $ do
          blockColumn { label: show $ entry ^. cbeEpoch
                      , mRoute: Just <<< Epoch <<< mkEpochIndex $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      , mCurrency: Nothing
                      }
          blockColumn { label: show $ entry ^. cbeSlot
                      , mRoute: Just <<< Block $ entry ^. cbeBlkHash
                      , clazz: CSS.blocksColumnSlot
                      , mCurrency: Nothing
                      }
          blockColumn { label: labelAge
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnAge
                      , mCurrency: Nothing
                      }
          blockColumn { label: show $ entry ^. cbeTxNum
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnTxs
                      , mCurrency: Nothing
                      }
          blockColumn { label: formatADA (entry ^. cbeTotalSent) $ state ^. lang
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnTotalSent
                      , mCurrency: Just ADA
                      }
          blockColumn { label: labelBlockLead
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnLead
                      , mCurrency: Nothing
                      }
          blockColumn { label: show $ entry ^. cbeSize
                      , mRoute: Nothing
                      , clazz: CSS.blocksColumnSize
                      , mCurrency: Nothing
                      }
    where
        language = state ^. lang
        labelAge = fromMaybe noData $ (prettyDuration language :: Milliseconds -> String) <<< diff state.now <$> (nominalDiffTimeToDateTime  =<< entry.cbeTimeIssued)
        labelBlockLead = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ take 7 <$> (entry ^. cbeBlockLead)

type BlockColumnProps =
    { label :: String
    , clazz :: String
    , mCurrency :: Maybe CCurrency
    , mRoute :: Maybe Route
    }

blockColumn :: BlockColumnProps -> P.HTML Action
blockColumn props =
    let tag = case props.mRoute of
                  Just route ->
                      S.a ! S.href (toUrl route)
                          #! P.onClick (Navigate $ toUrl route)
                  Nothing ->
                      S.div
    in
    tag ! S.className props.clazz
        $ if isJust props.mCurrency
              then S.span ! S.className (currencyCSSClass props.mCurrency)
                          $ S.text props.label
              else S.text props.label

type BlocksHeaderProps =
    { id :: String
    , label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { id: "1"
      , label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    , { id: "2"
      , label: translate (I18nL.common <<< I18nL.cAge) lang
      , clazz: CSS.blocksColumnAge
      }
    , { id: "3"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { id: "4"
      , label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
    , { id: "5"
      , label: translate (I18nL.common <<< I18nL.cBlockLead) lang
      , clazz: CSS.blocksColumnLead
      }
    , { id: "6"
      , label: translate (I18nL.common <<< I18nL.cSize) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.HTML Action
blocksHeaderView blocks lang =
    S.div ! S.className (CSS.blocksHeader <> if null blocks then " hide" else "")
          $ for_ (mkBlocksHeaderProps lang) blockHeaderItemView

blockHeaderItemView :: BlocksHeaderProps -> P.HTML Action
blockHeaderItemView props =
    S.div ! S.className props.clazz
          ! P.key props.id
          $ S.text props.label


Simplify Name parsing and add base function

  Name.base (Name.withSubscript x s) === s

module Lambda.Language.Name
  ( Name
  , from
  , withSubscript
  , base
  , next
  ) where

import Lambda.Prelude

import Data.Array (unsafeIndex)
import Data.Array as Array
import Data.Char (toCharCode)
import Data.String.CodeUnits (fromCharArray)
import Lambda.Language.Parser (class Parse, Parser, parse, liftJson, satisfy, string, token)
import Lambda.Language.Pretty (class Pretty, text)
import Partial.Unsafe (unsafePartial)

-- | Source-level name with an optional subscript.
data Name = Name String (Maybe Int)

derive instance eqName :: Eq Name
derive instance ordName :: Ord Name

instance showName :: Show Name where
  show (Name n ms) = n <> maybe "" intToSubscript ms

instance hashableName :: Hashable Name where
  hash (Name n ms) = hash $ Tuple n ms

instance decodeJsonName :: DecodeJson Name where
  decodeJson = liftJson parse <=< decodeJson

instance encodeJsonName :: EncodeJson Name where
  encodeJson = encodeJson <<< show

instance prettyName :: Pretty Name where
  pretty _ = text <<< show

-- | Construct a `Name` with no subscript.
from :: String -> Name
from s = Name s Nothing

-- | Construct a `Name` with a subscript.
withSubscript :: Int -> String -> Name
withSubscript n s = Name s $ Just n

-- | Append or increment a `Name`'s subscript.
next :: Name -> Name
next (Name n ms) = Name n $ (_ + 1) <$> ms <|> pure 0

-- | Extract a `Name`'s textual component
base :: Name -> String
base (Name s _) = s

-- | Parse a `Name`
-- |
-- | ```ebnf
-- | name
-- |   = (letter | "_")                           (* Initial letter or underscore *)
-- |   , {letter | "-"}                           (* Zero or more letters or hyphens *)
-- |   , ["?"]                                    (* Optional question mark *)
-- |   , {subscript | digit}                      (* Zero or more subscripts or digits *)
-- |   ;
-- |
-- | letter                                       (* Lowercase latin letters *)
-- |   = "a" | "b" | "c" | "d" | "e" | "f" | "g"
-- |   | "h" | "i" | "j" | "k" | "l" | "m" | "n"
-- |   | "o" | "p" | "q" | "r" | "s" | "t" | "u"
-- |   | "v" | "w" | "x" | "y" | "z" ;
-- |
-- | subscript                                    (* Subscripts *)
-- |   = "₀" | "₁" | "₂" | "₃" | "₄" | "₅" | "₆"
-- |   | "₇" | "₈" | "₉" ;
-- |
-- | digit                                        (* Decimal digits *)
-- |   = "0" | "1" | "2" | "3" | "4" | "5" | "6"
-- |   | "7" | "8" | "9" ;
-- | ```
-- |
instance parseName :: Parse Name where
  parse = token do
    first <- satisfy firstChar
    body <- Array.many $ satisfy bodyChar
    question <- string "?" <|> pure ""
    subscript <- Just <$> parseSubscript <|> pure Nothing
    let var = fromCharArray ([first] <> body) <> question
    pure $ Name var subscript

-- | Parse subscripts for a `Name`
parseSubscript :: Parser Int
parseSubscript = subscriptToInt <$> Array.some anyDigit

-- | Parse the first character of a `Name`
firstChar :: Char -> Boolean
firstChar c = isLower c || c == '_'

-- | Parse the remaining (non-question-mark, non-subscript-y)
-- | characters of a `Name`.
bodyChar :: Char -> Boolean
bodyChar c = isLower c || c == '-'

-- | Is a character a lowercase letter?
isLower :: Char -> Boolean
isLower c = 'a' <= c && c <= 'z'

-- | Convert `Int` subscript to textual subscript.
intToSubscript :: Int -> String
intToSubscript = fromCharArray <<< map (unsafePartial (subscriptTable `unsafeIndex` _)) <<< toDigits

-- | Convert textual subscript to `Int` subscript.
subscriptToInt :: Array Int -> Int
subscriptToInt = foldl step 0
 where
  step acc d = 10 * acc + d

-- | Parse a digit as its numeric value
anyDigit :: Parser Int
anyDigit = offsetFrom '0' '9' <|> offsetFrom '₀' '₉'

-- | Find charcter's offset from the lo end of the range
offsetFrom :: Char -> Char -> Parser Int
offsetFrom lo hi = do
  c <- satisfy inRange
  pure $ toCharCode c - toCharCode lo
 where
  inRange c = lo <= c && c <= hi

-- | Fixed array of actual subscript characters.
subscriptTable :: Array Char
subscriptTable = ['₀', '₁', '₂', '₃', '₄', '₅', '₆', '₇', '₈', '₉']

-- | Split decimal integer into its constituent digits.
toDigits :: Int -> Array Int
toDigits n
  | n < 10 = [n]
  | otherwise = toDigits (n `div` 10) <> [n `mod` 10]

module Lambda.Language.Name
  ( Name
  , from
  , withSubscript
  , next
  ) where

import Lambda.Prelude

import Data.Array (unsafeIndex)
import Data.Array as Array
import Data.Char (toCharCode)
import Data.Set as Set
import Data.String.CodeUnits (fromCharArray, toCharArray)
import Lambda.Language.Parser (class Parse, Parser, parse, liftJson, satisfy, string, token)
import Lambda.Language.Pretty (class Pretty, text)
import Partial.Unsafe (unsafePartial)

-- | Source-level name with an optional subscript.
data Name = Name String (Maybe Int)

derive instance eqName :: Eq Name
derive instance ordName :: Ord Name

instance showName :: Show Name where
  show (Name n ms) = n <> maybe "" intToSubscript ms

instance hashableName :: Hashable Name where
  hash (Name n ms) = hash $ Tuple n ms

instance decodeJsonName :: DecodeJson Name where
  decodeJson = liftJson parse <=< decodeJson

instance encodeJsonName :: EncodeJson Name where
  encodeJson = encodeJson <<< show

instance prettyName :: Pretty Name where
  pretty _ = text <<< show

-- | Construct a `Name` with no subscript.
from :: String -> Name
from s = Name s Nothing

-- | Construct a `Name` with a subscript.
withSubscript :: Int -> String -> Name
withSubscript n s = Name s $ Just n

-- | Append or increment a `Name`'s subscript.
next :: Name -> Name
next (Name n ms) = Name n $ (_ + 1) <$> ms <|> pure 0

-- | Parse a `Name`
-- |
-- | ```ebnf
-- | name
-- |   = (letter | "_")                           (* Initial letter or underscore *)
-- |   , {letter | "-"}                           (* Zero or more letters or hyphens *)
-- |   , ["?"]                                    (* Optional question mark *)
-- |   , {subscript | digit}                      (* Zero or more subscripts or digits *)
-- |   ;
-- |
-- | letter                                       (* Lowercase latin letters *)
-- |   = "a" | "b" | "c" | "d" | "e" | "f" | "g"
-- |   | "h" | "i" | "j" | "k" | "l" | "m" | "n"
-- |   | "o" | "p" | "q" | "r" | "s" | "t" | "u"
-- |   | "v" | "w" | "x" | "y" | "z" ;
-- |
-- | subscript                                    (* Subscripts *)
-- |   = "₀" | "₁" | "₂" | "₃" | "₄" | "₅" | "₆"
-- |   | "₇" | "₈" | "₉" ;
-- |
-- | digit                                        (* Decimal digits *)
-- |   = "0" | "1" | "2" | "3" | "4" | "5" | "6"
-- |   | "7" | "8" | "9" ;
-- | ```
-- |
instance parseName :: Parse Name where
  parse = token do
    first <- satisfy firstChar
    body <- Array.many $ satisfy bodyChar
    question <- string "?" <|> pure ""
    subscript <- Just <$> parseSubscript <|> pure Nothing
    let var = fromCharArray ([first] <> body) <> question
    pure $ Name var subscript

-- | Parse subscripts for a `Name`
parseSubscript :: Parser Int
parseSubscript = subscriptToInt <<< fromCharArray <$> Array.some (satisfy isSubscriptChar)

-- | Parse the first character of a `Name`
firstChar :: Char -> Boolean
firstChar c = isLower c || c == '_'

-- | Parse the remaining (non-question-mark, non-subscript-y)
-- | characters of a `Name`.
bodyChar :: Char -> Boolean
bodyChar c = isLower c || c == '-'

-- | Is a character a lowercase letter?
isLower :: Char -> Boolean
isLower c = 'a' <= c && c <= 'z'

-- | Convert `Int` subscript to textual subscript.
intToSubscript :: Int -> String
intToSubscript = fromCharArray <<< map (unsafePartial (subscriptTable `unsafeIndex` _)) <<< digits

-- | Convert textual subscript to `Int` subscript.
subscriptToInt :: String -> Int
subscriptToInt =
  foldl step 0 <<< toCharArray
 where
  step n c = 10 * n + toDigit c
  toDigit c
    | '0' <= c && c <= '9' = toCharCode c - toCharCode '0'
    | '₀' <= c && c <= '₉' = toCharCode c - toCharCode '₀'
    | otherwise            = 0

-- | Subscripts are digits or subscript digits
subscriptChars :: Set.Set Char
subscriptChars =
  Set.fromFoldable ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
    `Set.union`
        Set.fromFoldable subscriptTable

-- | Can input be parsed as a subscript?
isSubscriptChar :: Char -> Boolean
isSubscriptChar = (_ `Set.member` subscriptChars)

-- | Fixed array of actual subscript characters.
subscriptTable :: Array Char
subscriptTable = ['₀', '₁', '₂', '₃', '₄', '₅', '₆', '₇', '₈', '₉']

-- | Split decimal integer into its constituent digits.
digits :: Int -> Array Int
digits n
  | n < 10 = [n]
  | otherwise = digits (n `div` 10) <> [n `mod` 10]


AttributeKey

AttributeKey

module DOM
  ( Element()
  , Attribute()
  , Content()
  , AttributeKey()

  , a
  , div
  , p
  , img

  , href
  , _class
  , src
  , width
  , height

  , (:=)
  , text
  , elem

  , render
  ) where

import Data.Maybe
import Data.Array (map)
import Data.String (joinWith)

newtype Element = Element
  { name         :: String
  , attribs      :: [Attribute]
  , content      :: Maybe [Content]
  }

data Content
  = TextContent String
  | ElementContent Element

newtype Attribute = Attribute
  { key          :: String
  , value        :: String
  }

newtype AttributeKey a = AttributeKey String

element :: String -> [Attribute] -> Maybe [Content] -> Element
element name attribs content = Element
  { name:      name
  , attribs:   attribs
  , content:   content
  }

text :: String -> Content
text = TextContent

elem :: Element -> Content
elem = ElementContent

(:=) :: forall a. (Show a) => AttributeKey a -> a -> Attribute
(:=) (AttributeKey key) value = Attribute
  { key: key
  , value: show value
  }

a :: [Attribute] -> [Content] -> Element
a attribs content = element "a" attribs (Just content)

div :: [Attribute] -> [Content] -> Element
div attribs content = element "div" attribs (Just content)

p :: [Attribute] -> [Content] -> Element
p attribs content = element "p" attribs (Just content)

img :: [Attribute] -> Element
img attribs = element "img" attribs Nothing

href :: AttributeKey String
href = AttributeKey "href"

_class :: AttributeKey String
_class = AttributeKey "class"

src :: AttributeKey String
src = AttributeKey "src"

width :: AttributeKey Number
width = AttributeKey "width"

height :: AttributeKey Number
height = AttributeKey "height"

render :: Element -> String
render (Element e) =
  "<" ++ e.name ++
  " " ++ joinWith " " (map renderAttribute e.attribs) ++
  renderContent e.content

  where
  renderAttribute :: Attribute -> String
  renderAttribute (Attribute a) = a.key ++ "=\"" ++ a.value ++ "\""

  renderContent :: Maybe [Content] -> String
  renderContent Nothing = " />"
  renderContent (Just content) =
    ">" ++ joinWith "" (map renderContentItem content) ++
    "</" ++ e.name ++ ">"
    where
    renderContentItem :: Content -> String
    renderContentItem (TextContent s) = s
    renderContentItem (ElementContent e) = render e

module DOM
  ( Element()
  , Attribute()
  , Content()
  , a
  , div
  , p
  , img
  , render
  , (:=)
  , text
  , elem
  ) where

import Data.Maybe
import Data.Array (map)
import Data.String (joinWith)

newtype Element = Element
  { name         :: String
  , attribs      :: [Attribute]
  , content      :: Maybe [Content]
  }

data Content
  = TextContent String
  | ElementContent Element

newtype Attribute = Attribute
  { key          :: String
  , value        :: String
  }

element :: String -> [Attribute] -> Maybe [Content] -> Element
element name attribs content = Element
  { name:      name
  , attribs:   attribs
  , content:   content
  }

text :: String -> Content
text = TextContent

elem :: Element -> Content
elem = ElementContent

(:=) :: String -> String -> Attribute
(:=) key value = Attribute
  { key: key
  , value: value
  }

a :: [Attribute] -> [Content] -> Element
a attribs content = element "a" attribs (Just content)

div :: [Attribute] -> [Content] -> Element
div attribs content = element "div" attribs (Just content)

p :: [Attribute] -> [Content] -> Element
p attribs content = element "p" attribs (Just content)

img :: [Attribute] -> Element
img attribs = element "img" attribs Nothing

render :: Element -> String
render (Element e) =
  "<" ++ e.name ++
  " " ++ joinWith " " (map renderAttribute e.attribs) ++
  renderContent e.content

  where
  renderAttribute :: Attribute -> String
  renderAttribute (Attribute a) = a.key ++ "=\"" ++ a.value ++ "\""

  renderContent :: Maybe [Content] -> String
  renderContent Nothing = " />"
  renderContent (Just content) =
    ">" ++ joinWith "" (map renderContentItem content) ++
    "</" ++ e.name ++ ">"
    where
    renderContentItem :: Content -> String
    renderContentItem (TextContent s) = s
    renderContentItem (ElementContent e) = render e


Add Document

Add Document

module DOM where

-- | Effect type for DOM maniupulation
foreign import data DOM :: !

-- | General type for DOM documents.
foreign import data Document :: *

-- | General type for DOM nodes.
foreign import data Node :: *

-- | General type for DOM node lists.
foreign import data NodeList :: *

module DOM where

-- | Effect type for DOM maniupulation
foreign import data DOM :: !

-- | General type for DOM nodes.
foreign import data Node :: *

-- | General type for DOM node lists.
foreign import data NodeList :: *


All RefSpec tests ported

All RefSpec tests ported

module Test.RefSpec (refSpec) where

import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Prelude (Unit, bind, discard, ($), (>>=), (<>))
import Test.Spec (describe, it, Spec)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase (child, key, toString)
import Web.Firebase.Aff as FAff
import Web.Firebase.Types as FBT
import Web.Firebase.UnsafeRef (refFor)

refSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff | eff) Unit
refSpec ref = do
 describe "A reference in" do
   describe "Eff" do
     it "root reference is Nothing" do
       let rootKey = key ref
       rootKey `shouldEqual` Nothing
     it "key of root refences' child is child" do
       actual <- liftEff $ (child "achild" ref)
       (key actual) `shouldEqual` (Just "achild")
     describe "toString" do
       it "on root represents full database URl" do
         actual <- liftEff $ toString ref
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
       it "on child represents full database URl plus child" do
         actual <- liftEff $ (child "achild" ref) >>= toString
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/achild"
     describe "Aff" do
       describe "Getting a key" do
        it "on root throws an error" do
          expectError $ FAff.key ref
        it "on child of root returns child" do
          actual <- (FAff.child "affchild" ref) >>= FAff.key
          actual `shouldEqual` "affchild"
       describe "toString" do
         it "on root returns url" do
           actual <- FAff.toString ref
           actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
         it "on child of root returns root url + child" do
           let child = "achild"
           actual <- (FAff.child child ref) >>= FAff.toString
           actual `shouldEqual` ("https://purescript-spike.firebaseio.com/" <> child)

module Test.RefSpec (refSpec) where

import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Prelude (Unit, bind, discard, ($), (>>=))
import Test.Spec (describe, it, Spec)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase (child, key, toString)
import Web.Firebase.Aff as FAff
import Web.Firebase.Types as FBT
import Web.Firebase.UnsafeRef (refFor)

refSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff | eff) Unit
refSpec ref = do
 describe "A reference in" do
   describe "Eff" do
     it "root reference is Nothing" do
       let rootKey = key ref
       rootKey `shouldEqual` Nothing
     it "key of root refences' child is child" do
       actual <- liftEff $ (child "achild" ref)
       (key actual) `shouldEqual` (Just "achild")

refSpecOld :: forall eff. String -> Spec (firebase :: FBT.FirebaseEff | eff ) Unit
refSpecOld root = do
    describe "a Database reference" do
      describe "key with Eff" do
       it "on child of root returns child" do
         r <- refFor root
         actual <- liftEff $ (child "achild" r)
         (key actual) `shouldEqual` (Just "achild")
      describe "getting url with Eff" do
       it "on root returns url" do
         r <- refFor root
         actual <- liftEff $ toString r
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
       it "on child of root returns root url + child" do
         r <- refFor root
         actual <- liftEff $ (child "achild" r) >>= toString
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/achild"
      describe "with Aff" do
        describe "Getting a key" do
         it "on root throws an error" do
           r <- refFor root
           expectError $ FAff.key r
         it "on child of root returns child" do
           r <- refFor root
           actual <- (FAff.child "affchild" r) >>= FAff.key
           actual `shouldEqual` "affchild"
        describe "getting the url" do
          it "on root returns url" do
            r <- refFor root
            actual <- FAff.toString r
            actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
          it "on child of root returns root url + child" do
            r <- refFor root
            actual <- (FAff.child "achild" r) >>= FAff.toString
            actual `shouldEqual` "https://purescript-spike.firebaseio.com/achild"


Ok -> Rename

Ok -> Rename

module View.File.Modal.RenameDialog where

import Controller.File
import Model.File
import EffectTypes
import Control.Apply ((*>))
import Control.Functor (($>))
import Data.Maybe

import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B

import View.File.Modal.Common
import qualified View.Css as Vc
import qualified Config as Config

renameDialog :: forall p e. RenameDialogRec ->
                [H.HTML p (E.Event (FileAppEff e) Input)]
renameDialog dialog =
  [ header $ h4 "Rename"
  , body
    [ H.form [ E.onClick (E.input_ $ SetDialog
                          (Just (RenameDialog
                                 dialog{showList = false})))]
      [ H.div [ A.classes [B.formGroup]]
        [ H.input [ A.classes [B.formControl]
                  , A.value (removeExtension dialog.item.name)
                  , A.placeholder "New name"
                  , E.onInput (\v -> checkRename v dialog) ] []]
      , H.div [A.classes [B.inputGroup]]
        [ H.input [ A.classes [B.formControl]
                  , A.placeholder "New directory"
                  , E.onInput (renameItemClicked dialog.target)
                  , A.value (dialog.selected) ] []
        , H.span [ A.classes [B.inputGroupBtn]]
          [ H.button [ A.classes [B.btn, B.btnDefault]
                     , E.onClick (\_ -> E.stopPropagation $>
                                        (pure $  SetDialog
                                         (Just (RenameDialog
                                                dialog{showList = not dialog.showList}))))]
          [ H.span [ A.classes [B.caret]] []]]]
      , H.ul [A.classes $ [ B.listGroup
                          , Vc.directoryListGroup
                          , B.fade] <> if dialog.showList
                                       then [B.in_]
                                       else []]
        (renameItem dialog.target <$> dialog.dirs)
      , H.div [ E.onClick (E.input_ $ RenameError "")
              , A.classes $ [B.alert, B.alertDanger, B.fade ]
                <> (if Str.length dialog.error == 0
                    then []
                    else [B.in_]) ]
        [H.text dialog.error] ]]

  , footer [ H.button [ A.classes [B.btn, B.btnDanger]
                      , E.onClick (E.input_ $ SetDialog Nothing)]
             [ H.text "Cancel" ]
           , H.button [ A.disabled $ dialog.incorrect
                      , A.classes [B.btn, B.btnPrimary]
                      , E.onClick (\_ -> rename dialog.item
                                         (dialog.selected <> "/" <> dialog.target))]
             [H.text "Rename"]]
  ]
  where
  renameItem :: forall i. String -> String -> H.HTML p (_ Input)
  renameItem target dir =
    H.a [ A.href "#"
        , E.onClick (\_ -> E.preventDefault *> renameItemClicked target dir)
        , A.classes [B.listGroupItem]]
    [ H.text dir ]

  extensionRgx :: Rgx.Regex
  extensionRgx = Rgx.regex (Config.notebookExtension <> "$") Rgx.noFlags

  removeExtension :: String -> String
  removeExtension = Rgx.replace extensionRgx ""

module View.File.Modal.RenameDialog where

import Controller.File
import Model.File
import EffectTypes
import Control.Apply ((*>))
import Control.Functor (($>))
import Data.Maybe

import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B

import View.File.Modal.Common
import qualified View.Css as Vc
import qualified Config as Config

renameDialog :: forall p e. RenameDialogRec ->
                [H.HTML p (E.Event (FileAppEff e) Input)]
renameDialog dialog =
  [ header $ h4 "Rename"
  , body
    [ H.form [ E.onClick (E.input_ $ SetDialog
                          (Just (RenameDialog
                                 dialog{showList = false})))]
      [ H.div [ A.classes [B.formGroup]]
        [ H.input [ A.classes [B.formControl]
                  , A.value (removeExtension dialog.item.name)
                  , A.placeholder "New name"
                  , E.onInput (\v -> checkRename v dialog) ] []]
      , H.div [A.classes [B.inputGroup]]
        [ H.input [ A.classes [B.formControl]
                  , A.placeholder "New directory"
                  , E.onInput (renameItemClicked dialog.target)
                  , A.value (dialog.selected) ] []
        , H.span [ A.classes [B.inputGroupBtn]]
          [ H.button [ A.classes [B.btn, B.btnDefault]
                     , E.onClick (\_ -> E.stopPropagation $>
                                        (pure $  SetDialog
                                         (Just (RenameDialog
                                                dialog{showList = not dialog.showList}))))]
          [ H.span [ A.classes [B.caret]] []]]]
      , H.ul [A.classes $ [ B.listGroup
                          , Vc.directoryListGroup
                          , B.fade] <> if dialog.showList
                                       then [B.in_]
                                       else []]
        (renameItem dialog.target <$> dialog.dirs)
      , H.div [ E.onClick (E.input_ $ RenameError "")
              , A.classes $ [B.alert, B.alertDanger, B.fade ]
                <> (if Str.length dialog.error == 0
                    then []
                    else [B.in_]) ]
        [H.text dialog.error] ]]

  , footer [ H.button [ A.classes [B.btn, B.btnDanger]
                      , E.onClick (E.input_ $ SetDialog Nothing)]
             [ H.text "Cancel" ]
           , H.button [ A.disabled $ dialog.incorrect
                      , A.classes [B.btn, B.btnPrimary]
                      , E.onClick (\_ -> rename dialog.item
                                         (dialog.selected <> "/" <> dialog.target))]
             [H.text "Ok"]]
  ]
  where
  renameItem :: forall i. String -> String -> H.HTML p (_ Input)
  renameItem target dir =
    H.a [ A.href "#"
        , E.onClick (\_ -> E.preventDefault *> renameItemClicked target dir)
        , A.classes [B.listGroupItem]]
    [ H.text dir ]

  extensionRgx :: Rgx.Regex
  extensionRgx = Rgx.regex (Config.notebookExtension <> "$") Rgx.noFlags

  removeExtension :: String -> String
  removeExtension = Rgx.replace extensionRgx ""


Use correct type signature for main

Use correct type signature for main

module Main where

import App.Routes (match)
import App.Layout (Action(PageView), State, view, update)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Prelude (bind, return)
import Pux (App, Config, CoreEffects, fromSimple, renderToDOM)
import Pux.Router (sampleUrl)
import Signal ((~>))
import Signal.Channel (CHANNEL)

type AppEffects = (dom :: DOM)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  urlSignal <- sampleUrl

  -- | Map a signal of URL changes to PageView actions.
  let routeSignal = urlSignal ~> \r -> PageView (match r)

  return
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs: [routeSignal] }

-- | Entry point for the browser.
main :: State -> Eff (CoreEffects AppEffects) (App State Action)
main state = do
  app <- Pux.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  return app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  return app

module Main where

import App.Routes (match)
import App.Layout (Action(PageView), State, view, update)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Prelude (bind, return)
import Pux (App, Config, CoreEffects, fromSimple, renderToDOM)
import Pux.Router (sampleUrl)
import Signal ((~>))
import Signal.Channel (CHANNEL)

type AppEffects = (dom :: DOM)

-- | App configuration
config :: forall eff.
          State ->
          Eff (CoreEffects AppEffects)
            (Config State Action (channel :: CHANNEL | eff))
config state = do
  -- | Create a signal of URL changes.
  urlSignal <- sampleUrl

  -- | Map a signal of URL changes to PageView actions.
  let routeSignal = urlSignal ~> \r -> PageView (match r)

  return
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs: [routeSignal] }

-- | Entry point for the browser.
main :: State -> Eff (CoreEffects AppEffects) (App State Action)
main state = do
  app <- Pux.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  return app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  return app


Implement DOM.Node.Attr

Implement DOM.Node.Attr

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import qualified DOM.Node.Document as ND
import DOM.Node.Element hiding (id)
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N
import qualified Unsafe.Coerce as U
import DOM.Node.Attr

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

e2n :: Element -> Node
e2n = elementToNode

n2e :: Element -> Node
n2e = U.unsafeCoerce

htmlDoc :: forall eff. Eff (dom :: DOM | eff) HTMLDocument
htmlDoc = do
  w <- window
  document w

doc' :: forall eff. Eff (dom :: DOM | eff) Document
doc' = do
  d <- htmlDoc
  return $ coerceD d

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

body' :: forall eff. Eff (dom :: DOM | eff) Element
body' = do
  hb <- htmlBody
  return $ coerceE $ unsafeA hb

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  d <- doc'
  b <- body'
  img  <- ND.createElement "img" d
  _    <- setAttribute "src" (cardImgURL "Chill") img
  b1   <- N.appendChild (e2n img) (e2n b)
  src  <- getAttribute "src" img
  log $ show $ unsafeA src == cardImgURL "Chill"

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import DOM.Node.Element hiding (id)
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

unsafeA :: forall a. (Nullable a) -> a
unsafeA = fromJust <<< toMaybe

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  hb <- htmlBody
  let b = coerceE $ unsafeA $ hb
  hes  <- getElementsByClassName "card" b
  one  <- C.item 1 hes
  v    <- N.textContent $ elementToNode $ unsafeA $ one
  log $ "Wow! " ++ show v