Use the right source deck ID during eval

{-
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
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Promise as Pr
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.UI.Browser (newTab, locationObject, locationString, setHref)

import Data.Array as Array
import Data.Foldable (find, any)
import Data.Lens as Lens
import Data.Lens ((.~), (%~), (^?), (?~))
import Data.Lens.Prism.Coproduct (_Right)
import Data.List as L
import Data.Ord (max)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as Set
import Data.Time (Milliseconds(..))

import DOM.HTML.Location as Location

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

import SlamData.Config (workspaceUrl)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (parentURL)
import SlamData.Quasar.Data (save) as Quasar
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (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, _NextQuery)
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.Draftboard.Common as DBC
import SlamData.Workspace.Card.Eval as Eval
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot (cpBackSide, cpCard, cpIndicator, ChildQuery, ChildSlot, CardSlot(..), cpDialog)
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.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Indicator.Component as Indicator
import SlamData.Workspace.Deck.Model (deckIndex)
import SlamData.Workspace.Deck.Model as Model
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Model as WM
import SlamData.Workspace.Routing (mkWorkspaceHash, mkWorkspaceURL)
import SlamData.Workspace.StateMode (StateMode(..))
import SlamData.Workspace.Wiring (Wiring, CardEval, Cache, DeckMessage(..), getDeck, putDeck, putCardEval, getCache, makeCache)

import Utils.DOM (getBoundingClientRect)
import Utils.Path (DirPath)

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

render ∷ 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.
  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@{ wiring } = case _ of
  Init next → do
    pb ← subscribeToBus' (H.action ∘ RunPendingCards) wiring.pending
    mb ← subscribeToBus' (H.action ∘ HandleMessage) wiring.messaging
    H.modify $ DCS._breakers .~ [pb, mb]
    pure next
  Finish next → do
    H.modify _ { finalized = true }
    H.gets _.breakers >>= traverse_ (H.fromAff ∘ EventLoop.break')
    pure next
  Load dir deckId level next → do
    H.modify $ DCS._level .~ level
    loadDeck opts dir deckId
    pure next
  SetModel deckId model level next → do
    state ← H.get
    H.modify $ DCS._level .~ level
    setModel opts
      { path: state.path
      , id: deckId
      , parent: model.parent
      , modelCards: Tuple deckId <$> model.cards
      , name: state.name
      }
    pure next
  ExploreFile res next → do
    H.modify
      $ (DCS.addCard $ Card.cardModelOfType CT.JTable)
      ∘ (DCS.addCard ∘ Card.OpenResource ∘ Just $ R.File res)
      ∘ (DCS._stateMode .~ Preparing)
    initialCard ← H.gets (map DCS.coordModelToCoord ∘ Array.head ∘ _.modelCards)
    for_ initialCard $ queuePendingCard wiring
    saveDeck opts Nothing
    updateIndicator
    pure next
  Publish next → do
    path ← H.gets DCS.deckPath
    H.fromEff ∘ newTab $ mkWorkspaceURL path (WA.Load AT.ReadOnly)
    pure next
  -- TODO: How can we get rid of this? What is it's purpose? It smells.
  Reset path next → do
    st ← H.get
    setDeckState $
      (DCS.initialDeck path st.id)
        { stateMode = Ready
        , displayCards = [ st.id × nextActionCard ]
        , deckElement = st.deckElement
        }
    pure next
  SetParent parent next →
    H.modify (DCS._parent .~ Just parent) $> next
  GetModelCards k → k <$> getModelCards
  SetModelCards modelCards next → do
    st ← H.get
    setModel opts
      { path: st.path
      , id: st.id
      , parent: st.parent
      , modelCards
      , name: st.name
      }
    saveDeck opts Nothing
    pure next
  GetId k →
    k <$> H.gets _.id
  GetParent k →
    k <$> H.gets _.parent
  Save coord next →
    saveDeck opts coord $> next
  RunPendingCards { source, pendingCard, cards } next → do
    st ← H.get
    let pendingCoord = DCS.coordModelToCoord pendingCard
    when (any (DCS.eqCoordModel pendingCoord) st.modelCards) do
      runPendingCards opts source pendingCard cards
    pure next
  QueuePendingCard next → do
    H.gets _.pendingCard >>= traverse_ \pending → do
      modelCards ← getModelCards
      H.modify
        $ (DCS._modelCards .~ modelCards)
        ∘ (DCS._pendingCard .~ Nothing)
      queuePendingCard wiring pending
    pure next
  SetGlobalVarMap m next → do
    st ← H.get
    when (m ≠ st.globalVarMap) do
      H.modify $ DCS._globalVarMap .~ m
      traverse_ runCard $ DCS.apiCards st
    pure next
  FlipDeck next → do
    updateBackSide
    H.modify
      $ DCS._displayMode
      %~ case _ of
        DCS.Normal → DCS.Backside
        _ → DCS.Normal
    pure next
  GrabDeck _ next →
    pure next
  UpdateCardSize next → do
    H.queryAll' cpCard $ left $ H.action UpdateDimensions
    pure next
  ResizeDeck _ next →
    pure next
  ZoomIn next → do
    st ← H.get
    let deckHash = mkWorkspaceHash (DCS.deckPath st) (WA.Load opts.accessType) st.globalVarMap
    H.fromEff $ locationObject >>= Location.setHash deckHash
    pure next
  ZoomOut next → do
    st ← H.get
    case st.parent of
      Just (Tuple deckId _) → do
        let deckHash = mkWorkspaceHash (DCS.deckPath' st.path deckId) (WA.Load opts.accessType) st.globalVarMap
        H.fromEff $ locationObject >>= Location.setHash deckHash
      Nothing →
        void $ H.fromEff $ setHref $ parentURL $ Left st.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
    Slider.stopSlidingAndSnap mouseEvent
    updateIndicator
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  SetCardElement element next → do
    H.modify _ { deckElement = element }
    pure next
  StopSliderTransition next →
    H.modify (DCS._sliderTransition .~ false) $> next
  DoAction _ next → pure next
  Focus next → do
    st ← H.get
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      H.fromAff $ Bus.write (DeckFocused st.id) wiring.messaging
    pure next
  HandleMessage msg next → do
    case msg of
      DeckFocused focusedDeckId → do
        st <- H.get
        when (st.id /= focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next

  where
  getBoundingClientWidth =
    H.fromEff ∘ map _.width ∘ getBoundingClientRect

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

peekDialog ∷ ∀ a. DeckOptions → Dialog.Query a → DeckDSL Unit
peekDialog _ (Dialog.Show _ _) =
  H.modify (DCS._displayMode .~ DCS.Dialog)
peekDialog _ (Dialog.Dismiss _) =
  H.modify (DCS._displayMode .~ DCS.Backside)
peekDialog opts (Dialog.SetDeckName name _) =
  H.modify ((DCS._displayMode .~ DCS.Normal) ∘ (DCS._name .~ name))
    *> saveDeck opts Nothing
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 _) =
  case action of
    Back.Trash → do
      state ← H.get
      lastId ← H.gets DCS.findLastRealCard
      for_ (DCS.activeCardCoord state <|> lastId) \trashId → do
        let rem = DCS.removeCard trashId state
        DBC.childDeckIds (snd <$> fst rem) #
          H.fromAff ∘ runPar ∘ traverse_ (Par ∘ DBC.deleteGraph state.path)
        H.set $ snd rem
        triggerSave Nothing
        updateActiveCardAndIndicator
        H.modify $ DCS._displayMode .~ DCS.Normal
        DCS.activeCardCoord (snd rem)
          # maybe (runCardUpdates opts state.id L.Nil) (queuePendingCard opts.wiring)
      void $ H.queryAll' cpCard $ left $ H.action UpdateDimensions
    Back.Rename → do
      name ← H.gets _.name
      showDialog $ Dialog.Rename name
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Share → do
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Share deckPath
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Unshare → do
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Unshare deckPath
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Embed → do
      varMap ← H.gets _.globalVarMap
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Embed deckPath varMap
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Publish → do
      deckPath ← H.gets DCS.deckPath
      varMap ← H.gets _.globalVarMap
      showDialog $ Dialog.Publish deckPath varMap
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.DeleteDeck → do
      cards ← H.gets _.modelCards
      if Array.null cards
        then raise' $ H.action $ DoAction DeleteDeck
        else do
          showDialog Dialog.DeleteDeck
          H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Mirror → do
      H.modify $ DCS._displayMode .~ DCS.Normal
      raise' $ H.action $ DoAction Mirror
    Back.Wrap → raise' $ H.action $ DoAction Wrap
peekBackSide _ _ = pure unit

mkShareURL ∷ Port.VarMap → DeckDSL String
mkShareURL varMap = do
  loc ← H.fromEff locationString
  path ← H.gets DCS.deckPath
  pure $ loc ⊕ "/" ⊕ workspaceUrl ⊕ mkWorkspaceHash path (WA.Load AT.ReadOnly) varMap

peekCards ∷ ∀ a. Wiring → CardSlot → CardQueryP a → DeckDSL Unit
peekCards wiring (CardSlot cardId) = (const $ pure unit) ⨁ peekCardInner wiring cardId

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog =
  queryDialog
    ∘ H.action
    ∘ Dialog.Show

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 (CardSlot cid)
    ∘ right
    ∘ H.ChildF unit
    ∘ right

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

updateActiveCardAndIndicator ∷ DeckDSL Unit
updateActiveCardAndIndicator = do
  activeCardIndex ← H.gets _.activeCardIndex
  case activeCardIndex of
    Nothing → do
      H.modify $ \st →
        let
          lastCardIndex = max 0 $ Array.length st.displayCards - 1
          lastRealCardIndex = DCS.findLastRealCardIndex st
        in st { activeCardIndex = Just $ fromMaybe lastCardIndex lastRealCardIndex }
    Just _ → pure unit
  updateIndicator

updateIndicator ∷ DeckDSL Unit
updateIndicator = do
  cards ← H.gets _.displayCards
  H.query' cpIndicator unit
    $ H.action
    $ Indicator.UpdatePortList
    $ map (Card.modelCardType ∘ _.model ∘ snd) cards
  vid ← H.gets $ fromMaybe 0 ∘ _.activeCardIndex
  void $ H.query' cpIndicator unit $ H.action $ Indicator.UpdateActiveId vid

updateBackSide ∷ DeckDSL Unit
updateBackSide = do
  state ← H.get
  let ty = DCS.activeCardType state
  void
    $ H.query' cpBackSide unit
    $ H.action
    $ Back.UpdateCardType ty

createCard ∷ Wiring → CT.CardType → DeckDSL Unit
createCard wiring cardType = do
  deckId ← H.gets _.id
  (st × newCardId) ← H.gets ∘ DCS.addCard' $ Card.cardModelOfType cardType
  setDeckState st
  queuePendingCard wiring (deckId × newCardId)
  triggerSave $ Just (deckId × newCardId)

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

peekCardEvalQuery ∷ ∀ a. DeckId × CardId → CEQ.CardEvalQuery a → DeckDSL Unit
peekCardEvalQuery cardCoord = case _ of
  CEQ.ModelUpdated CEQ.StateOnlyUpdate _ → triggerSave (Just cardCoord)
  CEQ.ModelUpdated CEQ.EvalModelUpdate _ → runCard cardCoord *> triggerSave (Just cardCoord)
  CEQ.ZoomIn _ → raise' $ H.action ZoomIn
  _ → pure unit

peekAnyCard ∷ ∀ a. Wiring → DeckId × CardId → AnyCardQuery a → DeckDSL Unit
peekAnyCard wiring cardCoord q = do
  for_ (q ^? _NextQuery ∘ _Right ∘ Next._AddCardType) $ createCard wiring

nextActionCard ∷ Card.Model
nextActionCard =
  { cardId: NextActionCardId
  , model: Card.NextAction
  }

errorCard ∷ Card.Model
errorCard =
  { cardId: ErrorCardId
  , model: Card.ErrorCard
  }

pendingEvalCard ∷ Card.Model
pendingEvalCard =
  { cardId: PendingCardId
  , model: Card.PendingCard
  }

type UpdateAccum =
  { cards ∷ L.List (DeckId × Card.Model)
  , steps ∷ L.List CardEval
  , updates ∷ L.List CardEval
  }

type UpdateResult =
  { displayCards ∷ Array (DeckId × Card.Model)
  , updates ∷ L.List CardEval
  }

queuePendingCard
  ∷ Wiring
  → DeckId × CardId
  → DeckDSL Unit
queuePendingCard wiring pendingCoord = do
  st ← H.get
  for_ (find (DCS.eqCoordModel pendingCoord) st.modelCards) \pendingCard →
    H.fromAff do
      cards ← makeCache
      Bus.write { source: st.id, pendingCard, cards } wiring.pending

runPendingCards
  ∷ DeckOptions
  → DeckId
  → DeckId × Card.Model
  → Cache (DeckId × CardId) CardEval
  → DeckDSL Unit
runPendingCards opts source pendingCard pendingCards = do
  st ← H.get
  let
    pendingCoord = DCS.coordModelToCoord pendingCard
    splitCards = L.span (not ∘ DCS.eqCoordModel pendingCoord) $ L.toList st.modelCards
    prevCard = DCS.coordModelToCoord <$> L.last splitCards.init
    pendingCards = L.Cons pendingCard <$> L.tail splitCards.rest

  for_ pendingCards \cards → do
    input ← join <$> for prevCard (flip getCache opts.wiring.cards)
    steps ← resume st (input >>= _.output) cards
    runCardUpdates opts source steps

  where
  resume st = go L.Nil where
    go steps input L.Nil = pure $ L.reverse steps
    go steps input (L.Cons c cs) = do
      step ←
        getCache (DCS.coordModelToCoord c) pendingCards >>= case _ of
          Just ev → pure ev
          Nothing → do
            ev ← evalCard st.path st.globalVarMap input c
            putCardEval ev pendingCards
            putCardEval ev opts.wiring.cards
            pure ev
      go (L.Cons step steps) step.output cs

-- | When we initially eval a deck we want to use whatever is in the main cache.
-- | If we were to just queuePendingCard then everything would get freshly
-- | evaluated, which is unnecessary.
runInitialEval
  ∷ Wiring
  → DeckDSL Unit
runInitialEval wiring = do
  st ← H.get
  cards ← makeCache

  let
    cardCoords = DCS.coordModelToCoord <$> L.toList st.modelCards
    source = st.id

  for_ cardCoords \coord → do
    getCache coord wiring.cards >>= traverse_ \ev →
      putCardEval ev cards

  for_ (Array.head st.modelCards) \pendingCard →
    H.fromAff $ Bus.write { source, pendingCard, cards } wiring.pending

-- | Evaluates a card given an input and model.
evalCard
  ∷ DirPath
  → Port.VarMap
  → Maybe (Pr.Promise Port)
  → DeckId × Card.Model
  → DeckDSL CardEval
evalCard path globalVarMap input card = do
  output ← H.fromAff $ Pr.defer do
    input' ← for input Pr.wait
    case Card.modelToEval (snd card).model of
      Left err →
        pure $ Port.CardError $ "Could not evaluate card: " <> err
      Right cmd → do
        flip Eval.runEvalCard cmd
          { path
          , globalVarMap
          , cardCoord: DCS.coordModelToCoord card
          , input: input'
          }
  pure { input, card, output: Just output }

-- | Interprets a list of pending card evaluations into updates for the
-- | display cards. Takes care of the pending card, next action card and
-- | error card.
runCardUpdates ∷ DeckOptions → DeckId → L.List CardEval → DeckDSL Unit
runCardUpdates opts source steps = do
  st ← H.get
  let
    realCards = Array.filter (Lens.has _CardId ∘ _.cardId ∘ snd) st.displayCards
    loadedCards = foldr (Set.insert ∘ DCS.coordModelToCoord) Set.empty realCards
    pendingCm = st.id × pendingEvalCard
    nextActionStep =
      { card: st.id × nextActionCard
      , input: _.output =<< L.last steps
      , output: Nothing
      }
    updateSteps =
      if AT.isEditable opts.accessType
        then L.snoc steps nextActionStep
        else steps

  H.modify $
    DCS._displayCards .~ Array.snoc realCards pendingCm

  updateResult ←
    H.fromAff $ Pr.wait $
      updateCards st { steps: updateSteps, cards: mempty, updates: mempty }

  -- Splice in the new display cards and run their updates.
  for_ (Array.head updateResult.displayCards) \card → do
    let
      pendingId = DCS.coordModelToCoord card
      oldCards = Array.takeWhile (not ∘ DCS.eqCoordModel pendingId) realCards
      displayCards = oldCards <> updateResult.displayCards

    H.modify
      $ DCS._displayCards .~ displayCards

    for_ updateResult.updates $
      updateCard st source pendingId loadedCards

  -- Final cleanup
  when (st.stateMode == Preparing) do
    lastIndex ← H.gets DCS.findLastRealCardIndex
    H.modify
      $ (DCS._stateMode .~ Ready)
      ∘ (DCS._activeCardIndex .~ lastIndex)

  updateActiveCardAndIndicator

  where
  updateCards ∷ DCS.State → UpdateAccum → Pr.Promise UpdateResult
  updateCards st = case _ of
    { steps: L.Nil, cards, updates } →
      pure
        { displayCards: L.fromList $ L.reverse cards
        , updates: L.reverse updates
        }
    { steps: L.Cons x xs, cards, updates } → do
      output ← sequence x.output
      let cards' = L.Cons x.card cards
          updates' = L.Cons x updates
      updateCards st $ case output of
        Just (Port.CardError err) →
          let errorCard' = st.id × errorCard
              errorStep  = { input: x.output, output: Nothing, card: errorCard' }
          in
              { steps: L.Nil
              , cards: L.Cons errorCard' cards'
              , updates: L.Cons errorStep updates'
              }
        _ →
          { steps: xs
          , cards: cards'
          , updates: updates'
          }

  updateCard
    ∷ DCS.State
    → DeckId
    → DeckId × CardId
    → Set.Set (DeckId × CardId)
    → CardEval
    → DeckDSL Unit
  updateCard st source pendingId loadedCards step = void do
    input ← for step.input (H.fromAff ∘ Pr.wait)
    output ← for step.output (H.fromAff ∘ Pr.wait)

    let
      cardCoord = DCS.coordModelToCoord step.card
      evalInput = { path: st.path, globalVarMap: st.globalVarMap, input, cardCoord }

    -- We always load the card when we are updating a mirrored deck. This is
    -- so mirrors will always have the most recent model.
    when (not (Set.member cardCoord loadedCards) || st.id ≠ source) $ void do
      queryCardEval cardCoord $ H.action $ LoadCard (snd step.card)

    queryCardEval cardCoord $ H.action $ UpdateCard evalInput output

-- | Enqueues the card with the specified ID in the set of cards that are
-- | pending to run and enqueues a debounced query to trigger the cards to
-- | actually run.
runCard ∷ DeckId × CardId → DeckDSL Unit
runCard coord = do
  H.modify (DCS.addPendingCard coord)
  fireDebouncedQuery' (Milliseconds 500.0) DCS._runTrigger QueuePendingCard

-- | Triggers the H.query for autosave. This does not immediate perform the save
-- | H.action, but instead enqueues a debounced query to trigger the actual save.
triggerSave ∷ Maybe (DeckId × CardId) → DeckDSL Unit
triggerSave coord =
  fireDebouncedQuery' (Milliseconds 500.0) DCS._saveTrigger $ Save coord

-- | Saves the deck as JSON, using the current values present in the state.
saveDeck ∷ DeckOptions → Maybe (DeckId × CardId) → DeckDSL Unit
saveDeck { accessType, wiring } coord = do
  st ← H.get
  when (AT.isEditable accessType) do
    modelCards ← Array.span (not ∘ eq st.id ∘ fst) <$> getModelCards
    coord >>= DCS.eqCoordModel >>> flip find modelCards.init
      # maybe' (\_ → saveMainDeck st modelCards) (saveMirroredCard st)

  where
  saveMainDeck st modelCards = do
    let model =
          { parent: st.parent
          , mirror: map _.cardId <$> modelCards.init
          , cards: snd <$> modelCards.rest
          , name: st.name
          }

    when (isNothing st.parent) do
      let index = st.path </> Pathy.file "index"
      WM.getRoot index >>= case _ of
        Left _ → void $ WM.setRoot index st.id
        Right _ → pure unit

    putDeck st.id model wiring.decks
    Quasar.save (deckIndex st.path st.id) (Model.encode model) >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → do
        when (st.level ≡ DL.root) $ do
          path' ← H.gets DCS.deckPath
          let deckHash = mkWorkspaceHash path' (WA.Load accessType) st.globalVarMap
          H.fromEff $ locationObject >>= Location.setHash deckHash

  saveMirroredCard st (deckId × card) =
    getDeck st.path deckId wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right deck → do
        let cards = deck.cards <#> \c → if c.cardId == card.cardId then card else c
            model = deck { cards = cards }
        putDeck deckId model wiring.decks
        void $ Quasar.save (deckIndex st.path deckId) $ Model.encode model

setDeckState ∷ DCS.State → DeckDSL Unit
setDeckState newState =
  H.modify \oldState →
    newState { cardElementWidth = oldState.cardElementWidth }

loadDeck ∷ DeckOptions → DirPath → DeckId → DeckDSL Unit
loadDeck opts path deckId = do
  H.modify
    $ (DCS._stateMode .~ Loading)
    ∘ (DCS._displayCards .~ [ deckId × pendingEvalCard ])

  res ← runExceptT do
    deck ← ExceptT $ getDeck path deckId opts.wiring.decks
    mirroredCards ← ExceptT $ H.fromAff $ loadMirroredCards deck.mirror
    pure $ deck × (mirroredCards <> (Tuple deckId <$> deck.cards))

  case res of
    Left err →
      H.modify $ DCS._stateMode .~ Error "There was a problem decoding the saved deck"
    Right (deck × modelCards) →
      setModel opts
        { path
        , id: deckId
        , parent: deck.parent
        , modelCards
        , name: deck.name
        }
  where
  loadMirroredCards coords = do
    let deckIds = Array.nub (fst <$> coords)
    res ← sequence <$> runPar (traverse (Par ∘ flip (getDeck path) opts.wiring.decks) deckIds)
    pure $ hydrateCards coords =<< map (Array.zip deckIds) res

  hydrateCards coords decks =
    for coords \(deckId × cardId) →
      case find (eq deckId ∘ fst) decks of
        Nothing → Left "Deck not found"
        Just (_ × deck) →
          case find (eq cardId ∘ _.cardId) deck.cards of
            Nothing → Left "Card not found"
            Just card → Right (deckId × card)

setModel
  ∷ DeckOptions
  → { path ∷ DirPath
    , id ∷ DeckId
    , parent ∷ Maybe (DeckId × CardId)
    , modelCards ∷ Array (DeckId × Card.Model)
    , name ∷ String
    }
  → DeckDSL Unit
setModel opts model =
  case Array.head model.modelCards of
    Just pending → do
      st ← DCS.fromModel model <$>
        H.gets (DCS._stateMode .~ Preparing)
      setDeckState st
      runInitialEval opts.wiring
    Nothing → do
      st ← DCS.fromModel model <$> H.get
      setDeckState st
      runCardUpdates opts opts.id L.Nil

getModelCards ∷ DeckDSL (Array (DeckId × Card.Model))
getModelCards = do
  st ← H.get
  for st.modelCards \(deckId × card) → do
    currentState ←
      queryCardEval (deckId × card.cardId)
        $ H.request (SaveCard card.cardId $ Card.modelCardType card.model)
    pure $ deckId × (fromMaybe card currentState)

{-
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
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Promise as Pr
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.UI.Browser (newTab, locationObject, locationString, setHref)

import Data.Array as Array
import Data.Foldable (find, any)
import Data.Lens as Lens
import Data.Lens ((.~), (%~), (^?), (?~))
import Data.Lens.Prism.Coproduct (_Right)
import Data.List as L
import Data.Ord (max)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as Set
import Data.Time (Milliseconds(..))

import DOM.HTML.Location as Location

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

import SlamData.Config (workspaceUrl)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (parentURL)
import SlamData.Quasar.Data (save) as Quasar
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (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, _NextQuery)
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.Draftboard.Common as DBC
import SlamData.Workspace.Card.Eval as Eval
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot (cpBackSide, cpCard, cpIndicator, ChildQuery, ChildSlot, CardSlot(..), cpDialog)
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.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Indicator.Component as Indicator
import SlamData.Workspace.Deck.Model (deckIndex)
import SlamData.Workspace.Deck.Model as Model
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Model as WM
import SlamData.Workspace.Routing (mkWorkspaceHash, mkWorkspaceURL)
import SlamData.Workspace.StateMode (StateMode(..))
import SlamData.Workspace.Wiring (Wiring, CardEval, Cache, DeckMessage(..), getDeck, putDeck, putCardEval, getCache, makeCache)

import Utils.DOM (getBoundingClientRect)
import Utils.Path (DirPath)

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

render ∷ 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.
  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@{ wiring } = case _ of
  Init next → do
    pb ← subscribeToBus' (H.action ∘ RunPendingCards) wiring.pending
    mb ← subscribeToBus' (H.action ∘ HandleMessage) wiring.messaging
    H.modify $ DCS._breakers .~ [pb, mb]
    pure next
  Finish next → do
    H.modify _ { finalized = true }
    H.gets _.breakers >>= traverse_ (H.fromAff ∘ EventLoop.break')
    pure next
  Load dir deckId level next → do
    H.modify $ DCS._level .~ level
    loadDeck opts dir deckId
    pure next
  SetModel deckId model level next → do
    state ← H.get
    H.modify $ DCS._level .~ level
    setModel opts
      { path: state.path
      , id: deckId
      , parent: model.parent
      , modelCards: Tuple deckId <$> model.cards
      , name: state.name
      }
    pure next
  ExploreFile res next → do
    H.modify
      $ (DCS.addCard $ Card.cardModelOfType CT.JTable)
      ∘ (DCS.addCard ∘ Card.OpenResource ∘ Just $ R.File res)
      ∘ (DCS._stateMode .~ Preparing)
    initialCard ← H.gets (map DCS.coordModelToCoord ∘ Array.head ∘ _.modelCards)
    for_ initialCard $ queuePendingCard wiring
    saveDeck opts Nothing
    updateIndicator
    pure next
  Publish next → do
    path ← H.gets DCS.deckPath
    H.fromEff ∘ newTab $ mkWorkspaceURL path (WA.Load AT.ReadOnly)
    pure next
  -- TODO: How can we get rid of this? What is it's purpose? It smells.
  Reset path next → do
    st ← H.get
    setDeckState $
      (DCS.initialDeck path st.id)
        { stateMode = Ready
        , displayCards = [ st.id × nextActionCard ]
        , deckElement = st.deckElement
        }
    pure next
  SetParent parent next →
    H.modify (DCS._parent .~ Just parent) $> next
  GetModelCards k → k <$> getModelCards
  SetModelCards modelCards next → do
    st ← H.get
    setModel opts
      { path: st.path
      , id: st.id
      , parent: st.parent
      , modelCards
      , name: st.name
      }
    saveDeck opts Nothing
    pure next
  GetId k →
    k <$> H.gets _.id
  GetParent k →
    k <$> H.gets _.parent
  Save coord next →
    saveDeck opts coord $> next
  RunPendingCards { source, pendingCard, cards } next → do
    st ← H.get
    let pendingCoord = DCS.coordModelToCoord pendingCard
    when (any (DCS.eqCoordModel pendingCoord) st.modelCards) do
      runPendingCards opts pendingCard cards
    pure next
  QueuePendingCard next → do
    H.gets _.pendingCard >>= traverse_ \pending → do
      modelCards ← getModelCards
      H.modify
        $ (DCS._modelCards .~ modelCards)
        ∘ (DCS._pendingCard .~ Nothing)
      queuePendingCard wiring pending
    pure next
  SetGlobalVarMap m next → do
    st ← H.get
    when (m ≠ st.globalVarMap) do
      H.modify $ DCS._globalVarMap .~ m
      traverse_ runCard $ DCS.apiCards st
    pure next
  FlipDeck next → do
    updateBackSide
    H.modify
      $ DCS._displayMode
      %~ case _ of
        DCS.Normal → DCS.Backside
        _ → DCS.Normal
    pure next
  GrabDeck _ next →
    pure next
  UpdateCardSize next → do
    H.queryAll' cpCard $ left $ H.action UpdateDimensions
    pure next
  ResizeDeck _ next →
    pure next
  ZoomIn next → do
    st ← H.get
    let deckHash = mkWorkspaceHash (DCS.deckPath st) (WA.Load opts.accessType) st.globalVarMap
    H.fromEff $ locationObject >>= Location.setHash deckHash
    pure next
  ZoomOut next → do
    st ← H.get
    case st.parent of
      Just (Tuple deckId _) → do
        let deckHash = mkWorkspaceHash (DCS.deckPath' st.path deckId) (WA.Load opts.accessType) st.globalVarMap
        H.fromEff $ locationObject >>= Location.setHash deckHash
      Nothing →
        void $ H.fromEff $ setHref $ parentURL $ Left st.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
    Slider.stopSlidingAndSnap mouseEvent
    updateIndicator
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  SetCardElement element next → do
    H.modify _ { deckElement = element }
    pure next
  StopSliderTransition next →
    H.modify (DCS._sliderTransition .~ false) $> next
  DoAction _ next → pure next
  Focus next → do
    st ← H.get
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      H.fromAff $ Bus.write (DeckFocused st.id) wiring.messaging
    pure next
  HandleMessage msg next → do
    case msg of
      DeckFocused focusedDeckId → do
        st <- H.get
        when (st.id /= focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next

  where
  getBoundingClientWidth =
    H.fromEff ∘ map _.width ∘ getBoundingClientRect

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

peekDialog ∷ ∀ a. DeckOptions → Dialog.Query a → DeckDSL Unit
peekDialog _ (Dialog.Show _ _) =
  H.modify (DCS._displayMode .~ DCS.Dialog)
peekDialog _ (Dialog.Dismiss _) =
  H.modify (DCS._displayMode .~ DCS.Backside)
peekDialog opts (Dialog.SetDeckName name _) =
  H.modify ((DCS._displayMode .~ DCS.Normal) ∘ (DCS._name .~ name))
    *> saveDeck opts Nothing
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 _) =
  case action of
    Back.Trash → do
      state ← H.get
      lastId ← H.gets DCS.findLastRealCard
      for_ (DCS.activeCardCoord state <|> lastId) \trashId → do
        let rem = DCS.removeCard trashId state
        DBC.childDeckIds (snd <$> fst rem) #
          H.fromAff ∘ runPar ∘ traverse_ (Par ∘ DBC.deleteGraph state.path)
        H.set $ snd rem
        triggerSave Nothing
        updateActiveCardAndIndicator
        H.modify $ DCS._displayMode .~ DCS.Normal
        DCS.activeCardCoord (snd rem)
          # maybe (runCardUpdates opts L.Nil) (queuePendingCard opts.wiring)
      void $ H.queryAll' cpCard $ left $ H.action UpdateDimensions
    Back.Rename → do
      name ← H.gets _.name
      showDialog $ Dialog.Rename name
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Share → do
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Share deckPath
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Unshare → do
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Unshare deckPath
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Embed → do
      varMap ← H.gets _.globalVarMap
      deckPath ← H.gets DCS.deckPath
      showDialog $ Dialog.Embed deckPath varMap
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Publish → do
      deckPath ← H.gets DCS.deckPath
      varMap ← H.gets _.globalVarMap
      showDialog $ Dialog.Publish deckPath varMap
      H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.DeleteDeck → do
      cards ← H.gets _.modelCards
      if Array.null cards
        then raise' $ H.action $ DoAction DeleteDeck
        else do
          showDialog Dialog.DeleteDeck
          H.modify (DCS._displayMode .~ DCS.Dialog)
    Back.Mirror → do
      H.modify $ DCS._displayMode .~ DCS.Normal
      raise' $ H.action $ DoAction Mirror
    Back.Wrap → raise' $ H.action $ DoAction Wrap
peekBackSide _ _ = pure unit

mkShareURL ∷ Port.VarMap → DeckDSL String
mkShareURL varMap = do
  loc ← H.fromEff locationString
  path ← H.gets DCS.deckPath
  pure $ loc ⊕ "/" ⊕ workspaceUrl ⊕ mkWorkspaceHash path (WA.Load AT.ReadOnly) varMap

peekCards ∷ ∀ a. Wiring → CardSlot → CardQueryP a → DeckDSL Unit
peekCards wiring (CardSlot cardId) = (const $ pure unit) ⨁ peekCardInner wiring cardId

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog =
  queryDialog
    ∘ H.action
    ∘ Dialog.Show

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 (CardSlot cid)
    ∘ right
    ∘ H.ChildF unit
    ∘ right

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

updateActiveCardAndIndicator ∷ DeckDSL Unit
updateActiveCardAndIndicator = do
  activeCardIndex ← H.gets _.activeCardIndex
  case activeCardIndex of
    Nothing → do
      H.modify $ \st →
        let
          lastCardIndex = max 0 $ Array.length st.displayCards - 1
          lastRealCardIndex = DCS.findLastRealCardIndex st
        in st { activeCardIndex = Just $ fromMaybe lastCardIndex lastRealCardIndex }
    Just _ → pure unit
  updateIndicator

updateIndicator ∷ DeckDSL Unit
updateIndicator = do
  cards ← H.gets _.displayCards
  H.query' cpIndicator unit
    $ H.action
    $ Indicator.UpdatePortList
    $ map (Card.modelCardType ∘ _.model ∘ snd) cards
  vid ← H.gets $ fromMaybe 0 ∘ _.activeCardIndex
  void $ H.query' cpIndicator unit $ H.action $ Indicator.UpdateActiveId vid

updateBackSide ∷ DeckDSL Unit
updateBackSide = do
  state ← H.get
  let ty = DCS.activeCardType state
  void
    $ H.query' cpBackSide unit
    $ H.action
    $ Back.UpdateCardType ty

createCard ∷ Wiring → CT.CardType → DeckDSL Unit
createCard wiring cardType = do
  deckId ← H.gets _.id
  (st × newCardId) ← H.gets ∘ DCS.addCard' $ Card.cardModelOfType cardType
  setDeckState st
  queuePendingCard wiring (deckId × newCardId)
  triggerSave $ Just (deckId × newCardId)

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

peekCardEvalQuery ∷ ∀ a. DeckId × CardId → CEQ.CardEvalQuery a → DeckDSL Unit
peekCardEvalQuery cardCoord = case _ of
  CEQ.ModelUpdated CEQ.StateOnlyUpdate _ → triggerSave (Just cardCoord)
  CEQ.ModelUpdated CEQ.EvalModelUpdate _ → runCard cardCoord *> triggerSave (Just cardCoord)
  CEQ.ZoomIn _ → raise' $ H.action ZoomIn
  _ → pure unit

peekAnyCard ∷ ∀ a. Wiring → DeckId × CardId → AnyCardQuery a → DeckDSL Unit
peekAnyCard wiring cardCoord q = do
  for_ (q ^? _NextQuery ∘ _Right ∘ Next._AddCardType) $ createCard wiring

nextActionCard ∷ Card.Model
nextActionCard =
  { cardId: NextActionCardId
  , model: Card.NextAction
  }

errorCard ∷ Card.Model
errorCard =
  { cardId: ErrorCardId
  , model: Card.ErrorCard
  }

pendingEvalCard ∷ Card.Model
pendingEvalCard =
  { cardId: PendingCardId
  , model: Card.PendingCard
  }

type UpdateAccum =
  { cards ∷ L.List (DeckId × Card.Model)
  , steps ∷ L.List CardEval
  , updates ∷ L.List CardEval
  }

type UpdateResult =
  { displayCards ∷ Array (DeckId × Card.Model)
  , updates ∷ L.List CardEval
  }

queuePendingCard
  ∷ Wiring
  → DeckId × CardId
  → DeckDSL Unit
queuePendingCard wiring pendingCoord = do
  st ← H.get
  for_ (find (DCS.eqCoordModel pendingCoord) st.modelCards) \pendingCard →
    H.fromAff do
      cards ← makeCache
      Bus.write { source: st.id, pendingCard, cards } wiring.pending

runPendingCards
  ∷ DeckOptions
  → DeckId × Card.Model
  → Cache (DeckId × CardId) CardEval
  → DeckDSL Unit
runPendingCards opts pendingCard pendingCards = do
  st ← H.get
  let
    pendingCoord = DCS.coordModelToCoord pendingCard
    splitCards = L.span (not ∘ DCS.eqCoordModel pendingCoord) $ L.toList st.modelCards
    prevCard = DCS.coordModelToCoord <$> L.last splitCards.init
    pendingCards = L.Cons pendingCard <$> L.tail splitCards.rest

  for_ pendingCards \cards → do
    input ← join <$> for prevCard (flip getCache opts.wiring.cards)
    steps ← resume st (input >>= _.output) cards
    runCardUpdates opts steps

  where
  resume st = go L.Nil where
    go steps input L.Nil = pure $ L.reverse steps
    go steps input (L.Cons c cs) = do
      step ←
        getCache (DCS.coordModelToCoord c) pendingCards >>= case _ of
          Just ev → pure ev
          Nothing → do
            ev ← evalCard st.path st.globalVarMap input c
            putCardEval ev pendingCards
            putCardEval ev opts.wiring.cards
            pure ev
      go (L.Cons step steps) step.output cs

-- | When we initially eval a deck we want to use whatever is in the main cache.
-- | If we were to just queuePendingCard then everything would get freshly
-- | evaluated, which is unnecessary.
runInitialEval
  ∷ Wiring
  → DeckDSL Unit
runInitialEval wiring = do
  st ← H.get
  cards ← makeCache

  let
    cardCoords = DCS.coordModelToCoord <$> L.toList st.modelCards
    source = st.id

  for_ cardCoords \coord → do
    getCache coord wiring.cards >>= traverse_ \ev →
      putCardEval ev cards

  for_ (Array.head st.modelCards) \pendingCard →
    H.fromAff $ Bus.write { source, pendingCard, cards } wiring.pending

-- | Evaluates a card given an input and model.
evalCard
  ∷ DirPath
  → Port.VarMap
  → Maybe (Pr.Promise Port)
  → DeckId × Card.Model
  → DeckDSL CardEval
evalCard path globalVarMap input card = do
  output ← H.fromAff $ Pr.defer do
    input' ← for input Pr.wait
    case Card.modelToEval (snd card).model of
      Left err →
        pure $ Port.CardError $ "Could not evaluate card: " <> err
      Right cmd → do
        flip Eval.runEvalCard cmd
          { path
          , globalVarMap
          , cardCoord: DCS.coordModelToCoord card
          , input: input'
          }
  pure { input, card, output: Just output }

-- | Interprets a list of pending card evaluations into updates for the
-- | display cards. Takes care of the pending card, next action card and
-- | error card.
runCardUpdates ∷ DeckOptions → L.List CardEval → DeckDSL Unit
runCardUpdates opts steps = do
  st ← H.get
  let
    realCards = Array.filter (Lens.has _CardId ∘ _.cardId ∘ snd) st.displayCards
    loadedCards = foldr (Set.insert ∘ DCS.coordModelToCoord) Set.empty realCards
    pendingCm = st.id × pendingEvalCard
    nextActionStep =
      { card: st.id × nextActionCard
      , input: _.output =<< L.last steps
      , output: Nothing
      }
    updateSteps =
      if AT.isEditable opts.accessType
        then L.snoc steps nextActionStep
        else steps

  H.modify $
    DCS._displayCards .~ Array.snoc realCards pendingCm

  updateResult ←
    H.fromAff $ Pr.wait $
      updateCards st { steps: updateSteps, cards: mempty, updates: mempty }

  -- Splice in the new display cards and run their updates.
  for_ (Array.head updateResult.displayCards) \card → do
    let
      pendingId = DCS.coordModelToCoord card
      oldCards = Array.takeWhile (not ∘ DCS.eqCoordModel pendingId) realCards
      displayCards = oldCards <> updateResult.displayCards

    H.modify
      $ DCS._displayCards .~ displayCards

    for_ updateResult.updates $
      updateCard st opts.id pendingId loadedCards

  -- Final cleanup
  when (st.stateMode == Preparing) do
    lastIndex ← H.gets DCS.findLastRealCardIndex
    H.modify
      $ (DCS._stateMode .~ Ready)
      ∘ (DCS._activeCardIndex .~ lastIndex)

  updateActiveCardAndIndicator

  where
  updateCards ∷ DCS.State → UpdateAccum → Pr.Promise UpdateResult
  updateCards st = case _ of
    { steps: L.Nil, cards, updates } →
      pure
        { displayCards: L.fromList $ L.reverse cards
        , updates: L.reverse updates
        }
    { steps: L.Cons x xs, cards, updates } → do
      output ← sequence x.output
      let cards' = L.Cons x.card cards
          updates' = L.Cons x updates
      updateCards st $ case output of
        Just (Port.CardError err) →
          let errorCard' = st.id × errorCard
              errorStep  = { input: x.output, output: Nothing, card: errorCard' }
          in
              { steps: L.Nil
              , cards: L.Cons errorCard' cards'
              , updates: L.Cons errorStep updates'
              }
        _ →
          { steps: xs
          , cards: cards'
          , updates: updates'
          }

  updateCard
    ∷ DCS.State
    → DeckId
    → DeckId × CardId
    → Set.Set (DeckId × CardId)
    → CardEval
    → DeckDSL Unit
  updateCard st source pendingId loadedCards step = void do
    input ← for step.input (H.fromAff ∘ Pr.wait)
    output ← for step.output (H.fromAff ∘ Pr.wait)

    let
      cardCoord = DCS.coordModelToCoord step.card
      evalInput = { path: st.path, globalVarMap: st.globalVarMap, input, cardCoord }

    -- We always load the card when we are updating a mirrored deck. This is
    -- so mirrors will always have the most recent model.
    when (not (Set.member cardCoord loadedCards) || st.id ≠ source) $ void do
      queryCardEval cardCoord $ H.action $ LoadCard (snd step.card)

    queryCardEval cardCoord $ H.action $ UpdateCard evalInput output

-- | Enqueues the card with the specified ID in the set of cards that are
-- | pending to run and enqueues a debounced query to trigger the cards to
-- | actually run.
runCard ∷ DeckId × CardId → DeckDSL Unit
runCard coord = do
  H.modify (DCS.addPendingCard coord)
  fireDebouncedQuery' (Milliseconds 500.0) DCS._runTrigger QueuePendingCard

-- | Triggers the H.query for autosave. This does not immediate perform the save
-- | H.action, but instead enqueues a debounced query to trigger the actual save.
triggerSave ∷ Maybe (DeckId × CardId) → DeckDSL Unit
triggerSave coord =
  fireDebouncedQuery' (Milliseconds 500.0) DCS._saveTrigger $ Save coord

-- | Saves the deck as JSON, using the current values present in the state.
saveDeck ∷ DeckOptions → Maybe (DeckId × CardId) → DeckDSL Unit
saveDeck { accessType, wiring } coord = do
  st ← H.get
  when (AT.isEditable accessType) do
    modelCards ← Array.span (not ∘ eq st.id ∘ fst) <$> getModelCards
    coord >>= DCS.eqCoordModel >>> flip find modelCards.init
      # maybe' (\_ → saveMainDeck st modelCards) (saveMirroredCard st)

  where
  saveMainDeck st modelCards = do
    let model =
          { parent: st.parent
          , mirror: map _.cardId <$> modelCards.init
          , cards: snd <$> modelCards.rest
          , name: st.name
          }

    when (isNothing st.parent) do
      let index = st.path </> Pathy.file "index"
      WM.getRoot index >>= case _ of
        Left _ → void $ WM.setRoot index st.id
        Right _ → pure unit

    putDeck st.id model wiring.decks
    Quasar.save (deckIndex st.path st.id) (Model.encode model) >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → do
        when (st.level ≡ DL.root) $ do
          path' ← H.gets DCS.deckPath
          let deckHash = mkWorkspaceHash path' (WA.Load accessType) st.globalVarMap
          H.fromEff $ locationObject >>= Location.setHash deckHash

  saveMirroredCard st (deckId × card) =
    getDeck st.path deckId wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right deck → do
        let cards = deck.cards <#> \c → if c.cardId == card.cardId then card else c
            model = deck { cards = cards }
        putDeck deckId model wiring.decks
        void $ Quasar.save (deckIndex st.path deckId) $ Model.encode model

setDeckState ∷ DCS.State → DeckDSL Unit
setDeckState newState =
  H.modify \oldState →
    newState { cardElementWidth = oldState.cardElementWidth }

loadDeck ∷ DeckOptions → DirPath → DeckId → DeckDSL Unit
loadDeck opts path deckId = do
  H.modify
    $ (DCS._stateMode .~ Loading)
    ∘ (DCS._displayCards .~ [ deckId × pendingEvalCard ])

  res ← runExceptT do
    deck ← ExceptT $ getDeck path deckId opts.wiring.decks
    mirroredCards ← ExceptT $ H.fromAff $ loadMirroredCards deck.mirror
    pure $ deck × (mirroredCards <> (Tuple deckId <$> deck.cards))

  case res of
    Left err →
      H.modify $ DCS._stateMode .~ Error "There was a problem decoding the saved deck"
    Right (deck × modelCards) →
      setModel opts
        { path
        , id: deckId
        , parent: deck.parent
        , modelCards
        , name: deck.name
        }
  where
  loadMirroredCards coords = do
    let deckIds = Array.nub (fst <$> coords)
    res ← sequence <$> runPar (traverse (Par ∘ flip (getDeck path) opts.wiring.decks) deckIds)
    pure $ hydrateCards coords =<< map (Array.zip deckIds) res

  hydrateCards coords decks =
    for coords \(deckId × cardId) →
      case find (eq deckId ∘ fst) decks of
        Nothing → Left "Deck not found"
        Just (_ × deck) →
          case find (eq cardId ∘ _.cardId) deck.cards of
            Nothing → Left "Card not found"
            Just card → Right (deckId × card)

setModel
  ∷ DeckOptions
  → { path ∷ DirPath
    , id ∷ DeckId
    , parent ∷ Maybe (DeckId × CardId)
    , modelCards ∷ Array (DeckId × Card.Model)
    , name ∷ String
    }
  → DeckDSL Unit
setModel opts model =
  case Array.head model.modelCards of
    Just pending → do
      st ← DCS.fromModel model <$>
        H.gets (DCS._stateMode .~ Preparing)
      setDeckState st
      runInitialEval opts.wiring
    Nothing → do
      st ← DCS.fromModel model <$> H.get
      setDeckState st
      runCardUpdates opts L.Nil

getModelCards ∷ DeckDSL (Array (DeckId × Card.Model))
getModelCards = do
  st ← H.get
  for st.modelCards \(deckId × card) → do
    currentState ←
      queryCardEval (deckId × card.cardId)
        $ H.request (SaveCard card.cardId $ Card.modelCardType card.model)
    pure $ deckId × (fromMaybe card currentState)


Fix warnings generated by purescript-0.8.0

module Control.Monad.Eff.Random where

import Prelude ((<), (<$>), (-), (+), (*), return, bind, ($), one)

import Control.Monad.Eff (Eff())
import Data.Int (toNumber, floor)

-- | The `RANDOM` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data RANDOM :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random :: forall e. Eff (random :: RANDOM | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- | ``` purescript
-- | randomInt 1 10 >>= Console.print
-- | ```
-- | will print a random integer between 1 and 10.
randomInt :: forall e. Int -> Int -> Eff (random :: RANDOM | e) Int
randomInt low high = do
  n <- random
  let asNumber = (toNumber high - toNumber low + one) * n + toNumber low
  return $ floor asNumber

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- | ``` purescript
-- | randomRange 1.0 2.0 >>= Console.print
-- | ```
-- | will print a random number between 1 and 2.
randomRange :: forall e. Number -> Number -> Eff (random :: RANDOM | e) Number
randomRange min max = do
    n <- random
    return (n * (max - min) + min)

-- | Returns a random boolean value with an equal chance of being `true` or
-- | `false`.
randomBool :: forall e. Eff (random :: RANDOM | e) Boolean
randomBool = (< 0.5) <$> random

module Control.Monad.Eff.Random where

import Prelude

import Control.Monad.Eff (Eff())
import Data.Int (toNumber, floor)

-- | The `RANDOM` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data RANDOM :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random :: forall e. Eff (random :: RANDOM | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- | ``` purescript
-- | randomInt 1 10 >>= Console.print
-- | ```
-- | will print a random integer between 1 and 10.
randomInt :: forall e. Int -> Int -> Eff (random :: RANDOM | e) Int
randomInt low high = do
  n <- random
  let asNumber = (toNumber high - toNumber low + one) * n + toNumber low
  return $ floor asNumber

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- | ``` purescript
-- | randomRange 1.0 2.0 >>= Console.print
-- | ```
-- | will print a random number between 1 and 2.
randomRange :: forall e. Number -> Number -> Eff (random :: RANDOM | e) Number
randomRange min max = do
    n <- random
    return (n * (max - min) + min)

-- | Returns a random boolean value with an equal chance of being `true` or
-- | `false`.
randomBool :: forall e. Eff (random :: RANDOM | e) Boolean
randomBool = (< 0.5) <$> random


Refactor

Refactor

module Cherry
  ( BED
  , Config(..)
  , AppEffects
  , Tree
  , View
  , Subscription
  , app
  , select
  , reduce
  , router
  , navigateTo
  , redirectTo
  , goForward
  , goBack
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (newRef, readRef, modifyRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Data.Foldable (sequence_)
import Data.Foreign.Null (writeNull)
import Data.List (List(..), (!!), (:))
import Data.Maybe (maybe)
import Data.Nullable (toMaybe)
import Data.VirtualDOM (VNode, patch)
import Data.VirtualDOM.DOM (api)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event, EventType, EventTarget)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (popstate)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, forward, back)
import DOM.HTML.Location (pathname, search)
import DOM.HTML.Types (Window, HISTORY, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document, location, history)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (Node, elementToNode)

foreign import data BED :: !

type AppEffects e = (console :: CONSOLE, bed :: BED, dom :: DOM, history :: HISTORY | e)

type Tree e = VNode e Node Event

type View e s = s -> Tree e

type Subscription e = Eff e Unit

newtype Config e s = Config
  { selector :: String
  , state :: s
  , view :: View e s
  , subscriptions :: Array (Subscription e)
  }

foreign import select :: forall e s. (s -> s) -> Eff (bed :: BED | e) s

foreign import reduce :: forall e s. (s -> s) -> Eff (bed :: BED | e) Unit

foreign import requestAnimationFrame :: forall e. Eff (dom :: DOM | e) Unit ->
                                        Window ->
                                        Eff (dom :: DOM | e) Unit

foreign import dispatchEvent :: forall e. EventType ->
                                Window ->
                                Eff (dom :: DOM | e) Unit

app :: forall e s. Config (AppEffects e) s -> Eff (AppEffects e) Unit
app (Config { selector, state, view, subscriptions }) = do
  reduce (\_ -> state)
  historyRef <- unsafeRunRef $ newRef Nil
  sequence_ subscriptions
  draw $ render historyRef
    where
      container =
        let doc = htmlDocumentToParentNode <$> (window >>= document)
        in map elementToNode <<< toMaybe <$> (doc >>= querySelector selector)

      warn = log $ selector <> "is not found."

      patch' prev next target = patch api target prev next

      addHistory historyRef currentState = do
        modifyRef historyRef (\h -> (view currentState) : h)
        readRef historyRef

      render historyRef = do
        target <- container
        currentState <- select (\s -> s)
        history <- unsafeRunRef $ addHistory historyRef currentState
        maybe warn (patch' (history !! 1) (history !! 0)) target

      draw renderer = do
        renderer
        window >>= requestAnimationFrame (draw renderer)

router :: forall e. (String -> Eff (dom :: DOM | e) Unit) ->
          Eff (dom :: DOM | e) Unit
router matcher = do
  handler
  eventWindow >>= addEventListener popstate listener false
    where
      path = do
        l <- window >>= location
        (<>) <$> pathname l <*> search l
      handler = path >>= matcher
      listener = eventListener (\_ -> handler)

navigateTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
navigateTo url = do
  window >>= history >>= pushState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

redirectTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
redirectTo url = do
  window >>= history >>= replaceState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

goForward :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goForward = window >>= history >>= forward

goBack :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goBack = window >>= history >>= back

eventWindow :: forall e. Eff (dom :: DOM | e) EventTarget
eventWindow = windowToEventTarget <$> window

module Cherry
  ( BED
  , Config(..)
  , AppEffects
  , Tree
  , View
  , Subscription
  , app
  , select
  , reduce
  , router
  , navigateTo
  , redirectTo
  , goForward
  , goBack
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (newRef, readRef, modifyRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Data.Foldable (sequence_)
import Data.Foreign.Null (writeNull)
import Data.List (List(..), (!!), (:))
import Data.Maybe (maybe)
import Data.Nullable (toMaybe)
import Data.VirtualDOM (VNode, patch)
import Data.VirtualDOM.DOM (api)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event, EventType, EventTarget)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (popstate)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, forward, back)
import DOM.HTML.Location (pathname, search)
import DOM.HTML.Types (Window, HISTORY, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document, location, history)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (Node, elementToNode)

foreign import data BED :: !

type AppEffects e = (console :: CONSOLE, bed :: BED, dom :: DOM, history :: HISTORY | e)

type Tree e = VNode e Node Event

type View e s = s -> Tree e

type Subscription e = Eff e Unit

newtype Config e s = Config
  { selector :: String
  , state :: s
  , view :: View e s
  , subscriptions :: Array (Subscription e)
  }

foreign import select :: forall e s. (s -> s) -> Eff (bed :: BED | e) s

foreign import reduce :: forall e s. (s -> s) -> Eff (bed :: BED | e) Unit

foreign import requestAnimationFrame :: forall e. Eff (dom :: DOM | e) Unit ->
                                        Window ->
                                        Eff (dom :: DOM | e) Unit

foreign import dispatchEvent :: forall e. EventType ->
                                Window ->
                                Eff (dom :: DOM | e) Unit

app :: forall e s. Config (AppEffects e) s -> Eff (AppEffects e) Unit
app (Config { selector, state, view, subscriptions }) = do
  reduce (\_ -> state)
  historyRef <- unsafeRunRef $ newRef Nil
  sequence_ subscriptions
  draw $ render historyRef
    where
      container =
        let doc = htmlDocumentToParentNode <$> (window >>= document)
        in map elementToNode <<< toMaybe <$> (doc >>= querySelector selector)

      warn = log $ selector <> "is not found."

      patch' prev next target = patch api target prev next

      render historyRef = do
        target <- container
        currentState <- select (\s -> s)
        history <- unsafeRunRef do
          modifyRef historyRef (\h -> (view currentState) : h)
          readRef historyRef
        maybe warn (patch' (history !! 1) (history !! 0)) target

      draw renderer = do
        renderer
        window >>= requestAnimationFrame (draw renderer)

router :: forall e. (String -> Eff (dom :: DOM | e) Unit) ->
          Eff (dom :: DOM | e) Unit
router matcher = do
  handler
  eventWindow >>= addEventListener popstate listener false
    where
      path = do
        l <- window >>= location
        (<>) <$> pathname l <*> search l
      handler = path >>= matcher
      listener = eventListener (\_ -> handler)

navigateTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
navigateTo url = do
  window >>= history >>= pushState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

redirectTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
redirectTo url = do
  window >>= history >>= replaceState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

goForward :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goForward = window >>= history >>= forward

goBack :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goBack = window >>= history >>= back

eventWindow :: forall e. Eff (dom :: DOM | e) EventTarget
eventWindow = windowToEventTarget <$> window


[CSM-258] Fix error message

[CSM-258] Fix error message

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletAddress
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       , mkCWalletSetAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have exactly 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletSetAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> CT.CWalletMeta
mkCWalletMeta wName =
    CT.CWalletMeta { cwName: wName
                   }

mkCWalletAddress :: String -> CT.CWalletAddress
mkCWalletAddress = CWalletAddress

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wName
                   }

mkCWalletSetAssurance :: String -> CT.CWalletSetAssurance
mkCWalletSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletSetInit :: String -> String -> Int -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta:
                                CWalletSetMeta
                                    { cwsName: wSetName
                                    , cwsAssurance: mkCWalletSetAssurance wsAssurance
                                    , cwsUnit: wsUnit
                                    }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletAddress
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       , mkCWalletSetAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletSetAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> CT.CWalletMeta
mkCWalletMeta wName =
    CT.CWalletMeta { cwName: wName
                   }

mkCWalletAddress :: String -> CT.CWalletAddress
mkCWalletAddress = CWalletAddress

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wName
                   }

mkCWalletSetAssurance :: String -> CT.CWalletSetAssurance
mkCWalletSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletSetInit :: String -> String -> Int -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta:
                                CWalletSetMeta
                                    { cwsName: wSetName
                                    , cwsAssurance: mkCWalletSetAssurance wsAssurance
                                    , cwsUnit: wsUnit
                                    }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale


markers w/o size and series

markers w/o size and series

module SlamData.Workspace.Card.Setups.Geo.Marker.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Geo.Marker.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Array as A
import Data.Argonaut (Json, decodeJson, (.?))
import Data.List as L
import Data.StrMap as Sm
import Data.String as S
import Data.Foldable as F
import Data.Int as Int
import Data.Path.Pathy (currentDir, file, dir, (</>), (<.>))
import Data.URI as URI
import Data.URI (URIRef)

import Leaflet.Core as LC

import Math ((%))

import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Geo.Marker.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)

import SqlSquared as Sql

import Utils.Array (enumerate)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildMarker

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  $ [ r.lat # SCC.jcursorPrj # Sql.as "lat"
    , r.lng # SCC.jcursorPrj # Sql.as "lng"
    , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
    , sizeField
    ]
  ⊕ ( map mkProjection $ enumerate r.dims )
  where
  sizeField = case r.size of
    Nothing → SCC.nullPrj # Sql.as "size"
    Just sz → sz # SCC.jcursorPrj # Sql.as "size" # SCC.applyTransform sz
  mkProjection (ix × field) =
    field # SCC.jcursorPrj # Sql.as ("measure" ⊕ show ix) # SCC.applyTransform field

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ Just $ SCC.jcursorSql r.lat
    , Just $ SCC.jcursorSql r.lng
    , map SCC.jcursorSql r.series
    ]

type Item =
  { lat ∷ LC.Degrees
  , lng ∷ LC.Degrees
  , size ∷ Number
  , series ∷ String
  , dims ∷ Array Number
  }

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  latSem ← obj .? "lat"
  lngSem ← obj .? "lng"
  latNum ← maybe (Left "lat has incorrect semantics") Right $ Sem.maybeNumber latSem
  lngNum ← maybe (Left "lng has incorrect semantics") Right $ Sem.maybeNumber lngSem
  lat ← maybe (Left "incorrect degrees, should be impossible") Right $ LC.mkDegrees $ latNum % 360.0
  lng ← maybe (Left "incorrect degrees, should be impossible") Right $ LC.mkDegrees $ lngNum % 360.0
  size ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "size"
  series ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "series"
  let
    ks ∷ Array String
    ks = map ("measure" <> _) $ A.mapMaybe (S.stripPrefix $ S.Pattern "measure") $ Sm.keys obj
  dims ← for ks \k →
    map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? k
  pure { lat
       , lng
       , size
       , series
       , dims
       }

iconConf ∷ { iconUrl ∷ URIRef, iconSize ∷ LC.Point }
iconConf =
  { iconUrl: Right $ URI.RelativeRef
      (URI.RelativePart Nothing $ Just $ Right $ currentDir </> dir "img" </> file "marker" <.> "svg")
      Nothing
      Nothing
  , iconSize: 40 × 40
  }

buildMarker ∷ ModelR → Axes → Port.Port
buildMarker r _ =
  Port.GeoChart { build }
  where
  mkItems ∷ Array Json → Array Item
  mkItems = foldMap (foldMap A.singleton ∘ decodeItem)

  mkMaxLat ∷ Array Item → Number
  mkMaxLat = fromMaybe zero ∘ A.head ∘ A.reverse ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lat)

  mkMaxLng ∷ Array Item → Number
  mkMaxLng = fromMaybe zero ∘ A.head ∘ A.reverse ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lng)

  mkMinLat ∷ Array Item → Number
  mkMinLat = fromMaybe zero ∘ A.head ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lat)

  mkMinLng ∷ Array Item → Number
  mkMinLng = fromMaybe zero ∘ A.head ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lng)

  mkAvgLat ∷ Array Item → Number
  mkAvgLat items =
    F.sum lats / (Int.toNumber $ A.length lats)
    where
    lats = map (LC.degreesToNumber ∘ _.lat) items

  mkAvgLng ∷ Array Item → Number
  mkAvgLng items =
    F.sum lngs / (Int.toNumber $ A.length lngs)
    where
    lngs = map (LC.degreesToNumber ∘ _.lng) items

  mkMinSize ∷ Array Item → Number
  mkMinSize = fromMaybe zero ∘ A.head ∘ A.sort ∘ map _.size

  mkMaxSize ∷ Array Item → Number
  mkMaxSize = fromMaybe one ∘ A.head ∘ A.reverse ∘ A.sort ∘ map _.size

  mkSeries ∷ Array Item → Sm.StrMap C.Color
  mkSeries items = Sm.fromFoldable $ A.zip (A.sort $ A.nub $ map _.series items) colors

  build leaf records = do
    let
      items = mkItems records
      minLng = mkMinLng items
      maxLng = mkMaxLng items
      minLat = mkMinLat items
      maxLat = mkMaxLat items
      latDiff = maxLat - minLat
      lngDiff = maxLng - minLng
      avgLat = mkAvgLat items
      avgLng = mkAvgLng items
      zoomLat = 360.0 / latDiff
      zoomLng = 360.0 / lngDiff
      zoomInt = min (Int.floor zoomLat) (Int.floor zoomLng)
      series = mkSeries items
      minSize = mkMinSize items
      maxSize = mkMaxSize items
      sizeDistance = r.maxSize - r.minSize
      distance = maxSize - minSize
      mkRadius size
        | distance ≡ 0.0 = r.minSize
        | isNothing r.size = r.minSize
        | otherwise = r.maxSize - sizeDistance / distance * (maxSize - size)
      foldFn icon acc item@{lat, lng} = do
        layer
          ← if isNothing r.series && isNothing r.size
            then map LC.markerToLayer $ LC.marker {lat, lng} >>= LC.setIcon icon
            else
              map LC.circleMarkerToLayer
              $ LC.circleMarker
                  {lat, lng}
                  { radius: mkRadius item.size
                  , color: unsafePartial fromJust $ Sm.lookup item.series series
                  }
        pure $ A.cons layer acc

    zoom ← LC.mkZoom zoomInt

    view ← LC.mkLatLng avgLat avgLng

    icon ← LC.icon iconConf

    layers ← A.foldRecM (foldFn icon) [ ] items

    _ ← LC.setZoom zoom leaf
    LC.once "zoomend" (const $ void $ LC.setView view leaf) $ LC.mapToEvented leaf

    pure layers

module SlamData.Workspace.Card.Setups.Geo.Marker.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Geo.Marker.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Array as A
import Data.Argonaut (Json, decodeJson, (.?))
import Data.List as L
import Data.StrMap as Sm
import Data.String as S
import Data.Foldable as F
import Data.Int as Int

import Leaflet.Core as LC

import Math ((%))

import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Geo.Marker.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)

import SqlSquared as Sql

import Utils.Array (enumerate)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildMarker

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  $ [ r.lat # SCC.jcursorPrj # Sql.as "lat"
    , r.lng # SCC.jcursorPrj # Sql.as "lng"
    , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
    , sizeField
    ]
  ⊕ ( map mkProjection $ enumerate r.dims )
  where
  sizeField = case r.size of
    Nothing → SCC.nullPrj # Sql.as "size"
    Just sz → sz # SCC.jcursorPrj # Sql.as "size" # SCC.applyTransform sz
  mkProjection (ix × field) =
    field # SCC.jcursorPrj # Sql.as ("measure" ⊕ show ix) # SCC.applyTransform field

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ Just $ SCC.jcursorSql r.lat
    , Just $ SCC.jcursorSql r.lng
    , map SCC.jcursorSql r.series
    ]

type Item =
  { lat ∷ LC.Degrees
  , lng ∷ LC.Degrees
  , size ∷ Number
  , series ∷ String
  , dims ∷ Array Number
  }

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  latSem ← obj .? "lat"
  lngSem ← obj .? "lng"
  latNum ← maybe (Left "lat has incorrect semantics") Right $ Sem.maybeNumber latSem
  lngNum ← maybe (Left "lng has incorrect semantics") Right $ Sem.maybeNumber lngSem
  lat ← maybe (Left "incorrect degrees, should be impossible") Right $ LC.mkDegrees $ latNum % 360.0
  lng ← maybe (Left "incorrect degrees, should be impossible") Right $ LC.mkDegrees $ lngNum % 360.0
  size ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "size"
  series ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "series"
  let
    ks ∷ Array String
    ks = map ("measure" <> _) $ A.mapMaybe (S.stripPrefix $ S.Pattern "measure") $ Sm.keys obj
  dims ← for ks \k →
    map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? k
  pure { lat
       , lng
       , size
       , series
       , dims
       }

buildMarker ∷ ModelR → Axes → Port.Port
buildMarker r _ =
  Port.GeoChart { build }
  where
  mkItems ∷ Array Json → Array Item
  mkItems = foldMap (foldMap A.singleton ∘ decodeItem)

  mkMaxLat ∷ Array Item → Number
  mkMaxLat = fromMaybe zero ∘ A.head ∘ A.reverse ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lat)

  mkMaxLng ∷ Array Item → Number
  mkMaxLng = fromMaybe zero ∘ A.head ∘ A.reverse ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lng)

  mkMinLat ∷ Array Item → Number
  mkMinLat = fromMaybe zero ∘ A.head ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lat)

  mkMinLng ∷ Array Item → Number
  mkMinLng = fromMaybe zero ∘ A.head ∘ A.sort ∘ map (LC.degreesToNumber ∘ _.lng)

  mkAvgLat ∷ Array Item → Number
  mkAvgLat items =
    F.sum lats / (Int.toNumber $ A.length lats)
    where
    lats = map (LC.degreesToNumber ∘ _.lat) items

  mkAvgLng ∷ Array Item → Number
  mkAvgLng items =
    F.sum lngs / (Int.toNumber $ A.length lngs)
    where
    lngs = map (LC.degreesToNumber ∘ _.lng) items

  mkMinSize ∷ Array Item → Number
  mkMinSize = fromMaybe zero ∘ A.head ∘ A.sort ∘ map _.size

  mkMaxSize ∷ Array Item → Number
  mkMaxSize = fromMaybe one ∘ A.head ∘ A.reverse ∘ A.sort ∘ map _.size

  mkSeries ∷ Array Item → Sm.StrMap C.Color
  mkSeries items = Sm.fromFoldable $ A.zip (A.sort $ A.nub $ map _.series items) colors

  build leaf records = do
    let
      items = mkItems records
      minLng = mkMinLng items
      maxLng = mkMaxLng items
      minLat = mkMinLat items
      maxLat = mkMaxLat items
      latDiff = maxLat - minLat
      lngDiff = maxLng - minLng
      avgLat = mkAvgLat items
      avgLng = mkAvgLng items
      zoomLat = 360.0 / latDiff
      zoomLng = 360.0 / lngDiff
      zoomInt = min (Int.floor zoomLat) (Int.floor zoomLng)
      series = mkSeries items
      minSize = mkMinSize items
      maxSize = mkMaxSize items
      sizeDistance = r.maxSize - r.minSize
      distance = maxSize - minSize
      mkRadius size
        | distance ≡ 0.0 = minSize
        | otherwise = r.maxSize - sizeDistance / distance * (maxSize - size)
      foldFn acc item@{lat, lng} = do
        cm ←
          LC.circleMarker
          {lat, lng}
          { radius: mkRadius item.size
          , color: unsafePartial fromJust $ Sm.lookup item.series series
          }
        pure $ A.cons (LC.circleMarkerToLayer cm) acc

    zoom ← LC.mkZoom zoomInt

    view ← LC.mkLatLng avgLat avgLng

    layers ← A.foldRecM foldFn [ ] items

    _ ← LC.setZoom zoom leaf
    LC.once "zoomend" (const $ void $ LC.setView view leaf) $ LC.mapToEvented leaf

    pure layers


fix an uncurrying mistake on callback

fix an uncurrying mistake on callback

module D3.ForceSimulation where

import Data.Pair
import D3.Base (Index, D3, Eff)
import D3.Selection (Selection)
import Data.Foreign.Undefined (Undefined(Undefined), unUndefined)
import Data.Function.Eff (EffFn2, EffFn1, EffFn3, runEffFn1, runEffFn2, runEffFn3)
import Data.Function.Uncurried (mkFn2, Fn2)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (Unit, pure, bind)

foreign import data D3Simulation :: *
foreign import data D3Force      :: *

type Node = { id :: String, group :: Number }
type Link = { source :: String, target :: String, value :: Number }

type GroupedForceLayout = { nodes :: Array Node
                          , links :: Array Link }

-- for a type to be draggable it will have to have x and y fields for the drag callback to operate on
type ForceNode = { id :: String, group :: Number, x :: Number, y :: Number }
type ForceLink = { source :: ForceNode, target :: ForceNode, value :: Number }
type DraggableLayout = { nodes :: Array ForceNode
                       , links :: Array Link }

data ForceType      = Centering | Collision | Links | ManyBody | ForceX | ForceY
data SimulationType = Force

foreign import addForceFn          :: ∀ eff. EffFn3 (d3::D3|eff) String D3Force D3Simulation    D3Simulation
foreign import d3ForceSimulationFn :: ∀ eff. Eff    (d3::D3|eff)                                D3Simulation
foreign import linkIDFn            :: ∀ v eff. EffFn2 (d3::D3|eff) (Fn2 Node Index v) D3Force      D3Force
foreign import makeCenterForceFn   :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import makeCenterForceFnP  :: ∀ eff. EffFn1 (d3::D3|eff) (Array Number)                      D3Force
foreign import makeLinkForceFn     :: ∀ eff. EffFn1 (d3::D3|eff) (Array Link)                        D3Force
foreign import makeManyBodyForceFn :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import getLinksFn          :: ∀ eff. EffFn1 (d3::D3|eff) D3Simulation                   (Array Link)
foreign import setLinksFn          :: ∀ eff. EffFn2 (d3::D3|eff) (Array Link) D3Force                D3Force
foreign import getForceFn          :: ∀ eff. EffFn2 (d3::D3|eff) String       D3Simulation           D3Force
foreign import simulationNodesFn   :: ∀ eff. EffFn2 (d3::D3|eff) (Array Node) D3Simulation      D3Simulation
foreign import onTickFn            :: ∀ eff. EffFn2 (d3::D3|eff)
                                                    (Eff (d3::D3|eff) Unit)
                                                    D3Simulation
                                                    D3Simulation
foreign import defaultTickFn       :: ∀ eff. EffFn2 (d3::D3|eff) (Selection Node) (Selection Link)      Unit

defaultTick :: ∀ eff. Selection Node -> Selection Link -> Eff (d3::D3|eff) Unit
defaultTick = runEffFn2 defaultTickFn

d3ForceSimulation :: ∀ eff. SimulationType -> Eff (d3::D3|eff) D3Simulation
d3ForceSimulation Force = d3ForceSimulationFn

initNodes :: ∀ eff. Array Node -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
initNodes = runEffFn2 simulationNodesFn

onTick  :: forall eff. Eff (d3::D3|eff) Unit -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
onTick = runEffFn2 onTickFn

addForce :: ∀ eff. ForceType -> String -> D3Force -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
addForce Centering = runEffFn3 addForceFn
addForce Collision = runEffFn3 addForceFn -- "not implemented yet"
addForce Links     = runEffFn3 addForceFn
addForce ManyBody  = runEffFn3 addForceFn
addForce ForceX    = runEffFn3 addForceFn -- "not implemented yet"
addForce ForceY    = runEffFn3 addForceFn -- "not implemented yet"

-- This function will blow up if String doens't look up a valid force on this simulation TODO
getForce :: ∀ eff. String -> D3Simulation                         -> Eff (d3::D3|eff) D3Force
getForce name sim = runEffFn2 getForceFn name sim

-- || functions only for LINK force
makeLinkForce :: ∀ eff. Maybe (Array Link) -> Eff (d3::D3|eff) D3Force
makeLinkForce (Just ls) = runEffFn1 makeLinkForceFn   ls
makeLinkForce Nothing   = runEffFn1 makeLinkForceFn   []

setIDFunction :: ∀ v eff. (Node -> Index -> v) -> D3Force -> Eff (d3::D3|eff) D3Force -- Force HAS TO BE LINK FORCE HERE
setIDFunction f = runEffFn2 linkIDFn (mkFn2 f)

setLinks      :: ∀ eff. (Array Link) -> D3Force -> Eff (d3::D3|eff) D3Force
setLinks      = runEffFn2 setLinksFn

getLinks      :: ∀ eff. D3Simulation            -> Eff (d3::D3|eff) (Array Link)
getLinks      = runEffFn1 getLinksFn

-- || functions only for MANY BODY force
makeManyBody :: ∀ eff. Eff (d3::D3|eff) D3Force
makeManyBody = makeManyBodyForceFn

-- || functions only for CENTERING force
makeCenterForce :: ∀ eff. Maybe (Pair Number) -> Eff (d3::D3|eff) D3Force
makeCenterForce (Just (Pair x y)) = runEffFn1 makeCenterForceFnP [x,y]
makeCenterForce Nothing           = makeCenterForceFn

{-
Simulation API
  on
  find
  stop
  tick
  alpha
  force
  nodes
  restart
  alphaMin
  alphaDecay
  alphaTarget
  velocityDecay

Simulations typically compose multiple forces as desired. This module provides several for your enjoyment:

                x y radius strength iterations links id distance theta distanceMin distanceMax
  Centering     * *
  Collision           *       *         *
  Links                       *         *        *     *     *
  Many-Body                   *                                     *       *          *
  PositioningX  *             *
  PositioningY    *           *

  Constructors for forces
    Centering   [x,y]
    Collision   [radius]
    Links       [Links]
    ManyBody
    ForceX      [x]
    ForceY      [y]
-}

module D3.ForceSimulation where

import Data.Pair
import D3.Base (Index, D3, Eff)
import D3.Selection (Selection)
import Data.Foreign.Undefined (Undefined(Undefined), unUndefined)
import Data.Function.Eff (EffFn2, EffFn1, EffFn3, runEffFn1, runEffFn2, runEffFn3)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (Unit, pure, bind)

foreign import data D3Simulation :: *
foreign import data D3Force      :: *

type Node = { id :: String, group :: Number }
type Link = { source :: String, target :: String, value :: Number }

type GroupedForceLayout = { nodes :: Array Node
                          , links :: Array Link }

-- for a type to be draggable it will have to have x and y fields for the drag callback to operate on
type ForceNode = { id :: String, group :: Number, x :: Number, y :: Number }
type ForceLink = { source :: ForceNode, target :: ForceNode, value :: Number }
type DraggableLayout = { nodes :: Array ForceNode
                       , links :: Array Link }

data ForceType      = Centering | Collision | Links | ManyBody | ForceX | ForceY
data SimulationType = Force

foreign import addForceFn          :: ∀ eff. EffFn3 (d3::D3|eff) String D3Force D3Simulation    D3Simulation
foreign import d3ForceSimulationFn :: ∀ eff. Eff    (d3::D3|eff)                                D3Simulation
foreign import linkIDFn            :: ∀ v eff. EffFn2 (d3::D3|eff) (Node -> Index -> v) D3Force      D3Force
foreign import makeCenterForceFn   :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import makeCenterForceFnP  :: ∀ eff. EffFn1 (d3::D3|eff) (Array Number)                      D3Force
foreign import makeLinkForceFn     :: ∀ eff. EffFn1 (d3::D3|eff) (Array Link)                        D3Force
foreign import makeManyBodyForceFn :: ∀ eff. Eff    (d3::D3|eff)                                     D3Force
foreign import getLinksFn          :: ∀ eff. EffFn1 (d3::D3|eff) D3Simulation                   (Array Link)
foreign import setLinksFn          :: ∀ eff. EffFn2 (d3::D3|eff) (Array Link) D3Force                D3Force
foreign import getForceFn          :: ∀ eff. EffFn2 (d3::D3|eff) String       D3Simulation           D3Force
foreign import simulationNodesFn   :: ∀ eff. EffFn2 (d3::D3|eff) (Array Node) D3Simulation      D3Simulation
foreign import onTickFn            :: ∀ eff. EffFn2 (d3::D3|eff)
                                                    (Eff (d3::D3|eff) Unit)
                                                    D3Simulation
                                                    D3Simulation
foreign import defaultTickFn       :: ∀ eff. EffFn2 (d3::D3|eff) (Selection Node) (Selection Link)      Unit

defaultTick :: ∀ eff. Selection Node -> Selection Link -> Eff (d3::D3|eff) Unit
defaultTick = runEffFn2 defaultTickFn

d3ForceSimulation :: ∀ eff. SimulationType -> Eff (d3::D3|eff) D3Simulation
d3ForceSimulation Force = d3ForceSimulationFn

initNodes :: ∀ eff. Array Node -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
initNodes = runEffFn2 simulationNodesFn

onTick  :: forall eff. Eff (d3::D3|eff) Unit -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
onTick = runEffFn2 onTickFn

addForce :: ∀ eff. ForceType -> String -> D3Force -> D3Simulation -> Eff (d3::D3|eff) D3Simulation
addForce Centering = runEffFn3 addForceFn
addForce Collision = runEffFn3 addForceFn -- "not implemented yet"
addForce Links     = runEffFn3 addForceFn
addForce ManyBody  = runEffFn3 addForceFn
addForce ForceX    = runEffFn3 addForceFn -- "not implemented yet"
addForce ForceY    = runEffFn3 addForceFn -- "not implemented yet"

-- This function will blow up if String doens't look up a valid force on this simulation TODO
getForce :: ∀ eff. String -> D3Simulation                         -> Eff (d3::D3|eff) D3Force
getForce name sim = runEffFn2 getForceFn name sim

-- || functions only for LINK force
makeLinkForce :: ∀ eff. Maybe (Array Link) -> Eff (d3::D3|eff) D3Force
makeLinkForce (Just ls) = runEffFn1 makeLinkForceFn   ls
makeLinkForce Nothing   = runEffFn1 makeLinkForceFn   []

setIDFunction :: ∀ v eff. (Node -> Index -> v) -> D3Force -> Eff (d3::D3|eff) D3Force -- Force HAS TO BE LINK FORCE HERE
setIDFunction = runEffFn2 linkIDFn

setLinks      :: ∀ eff. (Array Link) -> D3Force -> Eff (d3::D3|eff) D3Force
setLinks      = runEffFn2 setLinksFn

getLinks      :: ∀ eff. D3Simulation            -> Eff (d3::D3|eff) (Array Link)
getLinks      = runEffFn1 getLinksFn

-- || functions only for MANY BODY force
makeManyBody :: ∀ eff. Eff (d3::D3|eff) D3Force
makeManyBody = makeManyBodyForceFn

-- || functions only for CENTERING force
makeCenterForce :: ∀ eff. Maybe (Pair Number) -> Eff (d3::D3|eff) D3Force
makeCenterForce (Just (Pair x y)) = runEffFn1 makeCenterForceFnP [x,y]
makeCenterForce Nothing           = makeCenterForceFn

{-
Simulation API
  on
  find
  stop
  tick
  alpha
  force
  nodes
  restart
  alphaMin
  alphaDecay
  alphaTarget
  velocityDecay

Simulations typically compose multiple forces as desired. This module provides several for your enjoyment:

                x y radius strength iterations links id distance theta distanceMin distanceMax
  Centering     * *
  Collision           *       *         *
  Links                       *         *        *     *     *
  Many-Body                   *                                     *       *          *
  PositioningX  *             *
  PositioningY    *           *

  Constructors for forces
    Centering   [x,y]
    Collision   [radius]
    Links       [Links]
    ManyBody
    ForceX      [x]
    ForceY      [y]
-}