Load child decks as well as mirrors

Load child decks as well as mirrors

{-
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.Eval.Persistence where

import SlamData.Prelude

import Control.Monad.Aff.AVar (AVar, takeVar, putVar, modifyVar, killVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Aff.Promise (wait, defer)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Fork (class MonadFork, fork)
import Control.Parallel (parSequence)

import Data.Array as Array
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Rational ((%))

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Data as Quasar
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.AccessType (isEditable)
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Eval as Eval
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Deck as Deck
import SlamData.Workspace.Eval.Graph (unfoldGraph, EvalGraph)
import SlamData.Workspace.Model as WM
import SlamData.Wiring (Wiring)
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache

import Utils (censor)
import Utils.Aff (laterVar)

defaultSaveDebounce ∷ Int
defaultSaveDebounce = 500

defaultEvalDebounce ∷ Int
defaultEvalDebounce = 500

type Persist f m a =
  ( Affable SlamDataEffects m
  , MonadAsk Wiring m
  , MonadFork Exn.Error m
  , Parallel f m
  , QuasarDSL m
  ) ⇒ a

putDeck ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
putDeck deckId deck = do
  { path, eval, accessType } ← Wiring.expose
  ref ← defer do
    res ←
      if isEditable accessType
        then Quasar.save (Deck.deckIndex path deckId) $ Deck.encode deck
        else pure (Right unit)
    pure $ res $> deck
  Cache.alter deckId (updateOrFork ref) eval.decks
  rmap (const unit) <$> wait ref
  where
    updateOrFork ref = case _ of
      Just cell →
        pure $ Just cell
          { value = ref
          , model = deck
          }
      Nothing → do
        cell ← { value: ref, model: deck, bus: _ } <$> fromAff Bus.make
        fork do
          populateCards deckId deck
          forkDeckProcess deckId cell.bus
        pure (Just cell)

saveDeck ∷ ∀ f m. Persist f m (Deck.Id → m Unit)
saveDeck deckId = do
  { eval } ← Wiring.expose
  newDeck ← runMaybeT do
    cell ← MaybeT $ Cache.get deckId eval.decks
    deck ← MaybeT $ censor <$> wait cell.value
    cards ← MaybeT $ sequence <$> traverse getCard (Tuple deckId ∘ _.cardId <$> deck.cards)
    pure deck { cards = (\c → c.value.model) <$> cards }
  for_ newDeck (void ∘ putDeck deckId)

-- | Loads a deck from a DeckId. Returns the model.
getDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Model))
getDeck =
  getDeck' >=> _.value >>> wait

-- | Loads a deck from a DeckId. This has the effect of loading decks from
-- | which it extends (for mirroring) and populating the card graph. Returns
-- | the "cell" (model promise paired with its message bus).
getDeck' ∷ ∀ f m. Persist f m (Deck.Id → m Deck.Cell)
getDeck' deckId = do
  { path, eval } ← Wiring.expose
  let
    cacheVar = Cache.unCache eval.decks
  decks ← fromAff (takeVar cacheVar)
  case Map.lookup deckId decks of
    Just cell → do
      fromAff $ putVar cacheVar decks
      pure cell
    Nothing → do
      value ← defer do
        let
          deckPath = Deck.deckIndex path deckId
        -- FIXME: Notify on failure
        result ← runExceptT do
          deck ← ExceptT $ (_ >>= Deck.decode >>> lmap QE.msgToQError) <$> Quasar.load deckPath
          _    ← ExceptT $ populateCards deckId deck
          pure deck
        case result of
          Left _ →
            fromAff $ modifyVar (Map.delete deckId) cacheVar
          Right model →
            Cache.alter deckId (pure ∘ map (_ { model = model })) eval.decks
        pure result
      cell ← { value, model: Deck.emptyDeck, bus: _ } <$> fromAff Bus.make
      fromAff do
        putVar cacheVar (Map.insert deckId cell decks)
      forkDeckProcess deckId cell.bus
      pure cell

-- | Populates the card eval graph based on a deck model. This may fail as it
-- | also attempts to load/hydrate foreign cards (mirrors) as well.
populateCards ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
populateCards deckId deck = runExceptT do
  { eval } ← Wiring.expose
  decks ←
    ExceptT $ sequence <$>
      parTraverse getDeck (Array.nub (fst <$> deck.mirror))
  let
    cards = List.fromFoldable deck.cards
  childDecks ←
    ExceptT $ sequence <$>
      parTraverse getDeck (List.nub (CM.childDeckIds ∘ _.model =<< cards))
  case Array.last deck.mirror of
    Nothing → lift $ threadCards eval.cards cards
    Just coord → do
      cell ← do
        mb ← Cache.get coord eval.cards
        case mb of
          Nothing → QE.throw ("Card not found in eval cache: " <> show coord)
          Just a  → pure a
      let
        next = case List.head cards of
          Nothing → Left deckId
          Just c  → Right (deckId × c.cardId)
        cell' = cell { next = next : cell.next }
      Cache.put coord cell' eval.cards
      lift $ threadCards eval.cards cards
  where
    threadCards cache = case _ of
      c : Nil →
        makeCell c Nil cache
      c : c' : cs → do
        makeCell c (pure c'.cardId) cache
        threadCards cache (c' : cs)
      Nil →
        pure unit

    makeCell card next cache = do
      let
        coord = deckId × card.cardId
      cell ← makeCardCell card Nothing (Right ∘ Tuple deckId <$> next)
      Cache.put coord cell cache
      forkCardProcess coord cell.bus

-- FIXME: Maybe we don't need this, we can just call all these directly.
forkDeckProcess ∷ ∀ f m . Persist f m (Deck.Id → Bus.BusRW Deck.EvalMessage → m Unit)
forkDeckProcess deckId = forkLoop case _ of
  Deck.Force source →
    queueEval' 0 source
  Deck.AddCard cty →
    addCard deckId cty >>= traverse_ \coord → do
      queueSave defaultSaveDebounce deckId
      queueEval' 0 (mempty × coord)
  Deck.RemoveCard coord → do
    removeCard deckId coord >>= traverse_ \_ → do
      queueSave defaultSaveDebounce deckId
  Deck.UpdateParent parent → do
    { eval } ← Wiring.expose
    deckCell ← getDeck' deckId
    mbDeck ← wait deckCell.value
    for_ mbDeck \deck → do
      let
        deck' = deck { parent = parent }
      value' ← defer (pure (Right deck'))
      Cache.put deckId (deckCell { value = value' }) eval.decks
      queueSave defaultSaveDebounce deckId
  _ →
    pure unit

forkCardProcess ∷ ∀ f m. Persist f m (Card.Coord → Bus.BusRW Card.EvalMessage → m Unit)
forkCardProcess coord@(deckId × cardId) = forkLoop case _ of
  Card.ModelChange source model → do
    { eval } ← Wiring.expose
    Cache.alter coord (pure ∘ map (updateCellModel model)) eval.cards
    mbGraph ← snapshotGraph coord
    for_ mbGraph \graph → do
      queueSave defaultSaveDebounce deckId
      queueEval defaultEvalDebounce source graph
  _ →
    pure unit

snapshotGraph ∷ ∀ f m. Persist f m (Card.Coord → m (Maybe EvalGraph))
snapshotGraph coord = do
  { eval } ← Wiring.expose
  unfoldGraph
    <$> Cache.snapshot eval.cards
    <*> Cache.snapshot eval.decks
    <*> pure coord

queueSave ∷ ∀ f m. Persist f m (Int → Deck.Id → m Unit)
queueSave ms deckId = do
  { eval } ← Wiring.expose
  debounce ms deckId { avar: _ } eval.pendingSaves do
    saveDeck deckId

queueEval ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → EvalGraph → m Unit)
queueEval ms source@(_ × coord) graph = do
  { eval } ← Wiring.expose
  let
    pending =
      { source
      , graph
      , avar: _
      }
  -- TODO: Notify pending immediately
  debounce ms coord pending eval.pendingEvals do
    Eval.evalGraph source graph

queueEval' ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → m Unit)
queueEval' ms source@(_ × coord) =
  traverse_ (queueEval ms source) =<< snapshotGraph coord

freshWorkspace ∷ ∀ f m. Persist f m (m (Deck.Id × Deck.Cell))
freshWorkspace = do
  { eval } ← Wiring.expose
  rootId ← fromAff DID.make
  bus ← fromAff Bus.make
  value ← defer (pure (Right Deck.emptyDeck))
  let
    cell = { bus, value, model: Deck.emptyDeck }
  Cache.put rootId cell eval.decks
  forkDeckProcess rootId bus
  pure (rootId × cell)

wrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    parentDeck = DM.wrappedDeck deck.parent (snd parentCoord) deckId
  ExceptT $ putDeck (fst parentCoord) parentDeck
  ExceptT $ updateParentPointer deckId (fst parentCoord) deck.parent
  fromAff $ Bus.write (Deck.UpdateParent (Just parentCoord)) cell.bus
  pure (fst parentCoord)

wrapAndMirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapAndMirrorDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    wrappedDeck =
      DM.splitDeck deck.parent (snd parentCoord) Orn.Vertical
        (List.fromFoldable [ deckId, newMirrorId ])
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { parent = Just parentCoord }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          , updateParentPointer deckId (fst parentCoord) deck.parent
          ]
      else do
        let
          oldCardIds = Tuple deckId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just parentCoord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          , updateParentPointer deckId (fst parentCoord) deck.parent
          ]
  lift $ relocateCardsTo newSharedId deckId (_.cardId <$> deck.cards)
  pure (fst parentCoord)

mirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Deck.Id))
mirrorDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  parent ← liftWithErr "Parent not found." $ getCard coord
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { name = "" }
        parSequence
          [ putDeck newMirrorId mirrored
          ]
      else do
        let
          oldCardIds = Tuple childId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just coord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        parSequence
          [ putDeck childId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          ]
  lift $ relocateCardsTo newSharedId childId (_.cardId <$> deck.cards)
  parent'' ← liftWithErr "Cannot mirror deck." $ pure $ mirrorInLayout newMirrorId parent.value.model.model
  fromAff $ Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  pure newMirrorId
  where
  mirrorInLayout newId = case _ of
    CM.Draftboard { layout } → do
      cursor ← List.tail =<< Pane.getCursorFor (Just childId) layout
      let
        orn =
          case Pane.getAt cursor layout of
            Just (Pane.Split o _) → o
            _ → Orn.Vertical
      layout' ←
        Layout.insertSplit
          (Pane.Cell (Just newId)) orn (1%2) Layout.SideB cursor layout
      pure (CM.Draftboard { layout: layout' })
    _ →
      Nothing

unwrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
unwrapDeck deckId = runExceptT do
  deck ← ExceptT $ getDeck deckId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords deckId deck)
  childId ← liftWithErr "Cannot unwrap deck." $ pure $ immediateChild (_.value.model.model ∘ snd <$> cards)
  cell ← lift $ getDeck' childId
  ExceptT $ updateParentPointer deckId childId deck.parent
  fromAff $ Bus.write (Deck.UpdateParent deck.parent) cell.bus
  pure childId
  where
    immediateChild = case _ of
      [ model ] →
        case CM.childDeckIds model of
          childId : Nil → Just childId
          _ → Nothing
      _ → Nothing

collapseDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
collapseDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords childId deck)
  parent ← liftWithErr "Parent not found." $ getCard coord
  let
    parent' = parent.value.model.model
    cards' = _.value.model.model ∘ snd <$> cards
  childIds × parent'' ← liftWithErr "Cannot collapse deck." $ pure $ collapsed parent' cards'
  childDecks ← lift $ traverse getDeck' childIds
  fromAff do
    for_ childDecks \{ bus } →
      Bus.write (Deck.UpdateParent (Just coord)) bus
    Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  where
    collapsed parent child = case parent, child of
      CM.Draftboard { layout }, [ cm@CM.Draftboard { layout: subLayout } ] → do
        cursor ← Pane.getCursorFor (Just childId) layout
        layout' ← Pane.modifyAt (const subLayout) cursor layout
        let
          childIds = CM.childDeckIds cm
          parent' = CM.Draftboard { layout: layout' }
        pure (childIds × parent')
      _, _ →
        Nothing

addCard ∷ ∀ f m. Persist f m (Deck.Id → CT.CardType → m (Either QE.QError Card.Coord))
addCard deckId cty = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  cardId ← fromAff CID.make
  let
    coord = deckId × cardId
  lift do
    input ← runMaybeT do
      last ← MaybeT $ pure $ Array.last (Deck.cardCoords deckId deck)
      cell ← MaybeT $ Cache.get last eval.cards
      let
        next' = List.filter (not ∘ eq (Left deckId)) cell.next
        cell' = cell { next = Right coord : next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    let
      card = { cardId, model: Card.cardModelOfType (fromMaybe Port.Initial input) cty }
      deck' = deck { cards = Array.snoc deck.cards card }
    cell ← makeCardCell card input mempty
    value' ← defer (pure (Right deck'))
    Cache.put (deckId × cardId) cell eval.cards
    Cache.put deckId (deckCell { value = value' }) eval.decks
    forkCardProcess coord cell.bus
    pure coord

removeCard ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
removeCard deckId coord@(deckId' × cardId) = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  lift do
    let
      coords = Array.span (not ∘ eq coord) (Deck.cardCoords deckId deck)
      deck' =
        if deckId ≡ deckId'
          then deck { cards = Array.takeWhile (not ∘ eq cardId ∘ _.cardId) deck.cards }
          else deck { cards = [], mirror = Array.takeWhile (not ∘ eq coord) deck.mirror }
    output ← runMaybeT do
      last ← MaybeT $ pure $ Array.last coords.init
      cell ← MaybeT $ Cache.get last eval.cards
      let
        leaf = if Array.null deck'.cards then pure (Left deckId) else mempty
        next' = List.delete (Right coord) cell.next
        cell' = cell { next = leaf <> next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    value' ← defer (pure (Right deck'))
    Cache.put deckId (deckCell { value = value' }) eval.decks
    fromAff $ Bus.write (Deck.Complete coords.init (fromMaybe Port.Initial output)) deckCell.bus

updateParentPointer
  ∷ ∀ f m
  . Persist f m
  ( Deck.Id
  → Deck.Id
  → Maybe Card.Coord
  → m (Either QE.QError Unit) )
updateParentPointer oldId newId parent =
  runExceptT case parent of
    Just coord@(deckId × cardId) → do
      -- We need to guard on the parentDeck because it may not be loaded if we
      -- are viewing the child at the root of the UI.
      parentDeck ← ExceptT $ getDeck deckId
      cell ← getCard coord
      for_ cell \{ bus, value } → do
        let
          model' = CM.updatePointer oldId (Just newId) value.model.model
          message = Card.ModelChange (Card.toAll coord) model'
        fromAff $ Bus.write message bus
    Nothing → do
      { path } ← Wiring.expose
      ExceptT $ WM.setRoot (path </> Pathy.file "index") newId

relocateCardsTo ∷ ∀ f m . Persist f m (Deck.Id → Deck.Id → Array Card.Id → m Unit)
relocateCardsTo deckId oldDeckId coords = do
  { eval } ← Wiring.expose
  cards ← getCards (Tuple oldDeckId <$> coords)
  for_ cards (go eval.cards ∘ List.fromFoldable ∘ map snd)
  where
    go cache = case _ of
      c : Nil → do
        let
          cardId = c.value.model.cardId
          coord = deckId × cardId
          next = Left oldDeckId : c.next
        fromAff $ Bus.kill (Exn.error "Relocated") c.bus
        Cache.remove (oldDeckId × cardId) cache
        Cache.alter coord
          (pure ∘ map \c' → c' { value = c.value, next = Left oldDeckId : c'.next })
          cache
      c1 : c2 : cs → do
        let
          cardId1 = c1.value.model.cardId
          cardId2 = c2.value.model.cardId
          coord2 = oldDeckId × cardId2
          coord = deckId × cardId1
          updateNext = map (map \c → if c ≡ coord2 then deckId × cardId2 else c)
        fromAff $ Bus.kill (Exn.error "Relocated") c1.bus
        Cache.remove (oldDeckId × cardId1) cache
        Cache.alter coord
          (pure ∘ map \c' → c' { value = c1.value, next = updateNext c'.next })
          cache
        go cache (c2 : cs)
      Nil →
        pure unit

forkLoop
  ∷ ∀ m r a
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    )
  ⇒ (a → m Unit)
  → Bus.Bus (Bus.R' r) a
  → m Unit
forkLoop handler bus = void (fork loop)
  where
    loop = do
      msg ← fromAff (Bus.read bus)
      fork (handler msg)
      loop

makeCardCell
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , Monad m
    )
  ⇒ Card.Model
  → Maybe Port
  → List (Either Deck.Id Card.Coord)
  → m Card.Cell
makeCardCell model input next = do
  let
    value ∷ Card.EvalResult
    value =
      { model
      , input
      , output: Nothing
      , state: Nothing
      , sources: mempty
      , tick: Nothing
      }
  bus ← fromAff Bus.make
  pure { bus, next, value }

getCard
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Card.Coord
  → m (Maybe Card.Cell)
getCard coord = do
  { eval } ← Wiring.expose
  Cache.get coord eval.cards

getCards
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Array Card.Coord
  → m (Maybe (Array (Deck.Id × Card.Cell)))
getCards = map sequence ∘ traverse go
  where
    go coord = map (fst coord × _) <$> getCard coord

debounce
  ∷ ∀ k m r
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    , Ord k
    )
  ⇒ Int
  → k
  → (AVar Unit → { avar ∷ AVar Unit | r })
  → Cache.Cache k { avar ∷ AVar Unit | r }
  → m Unit
  → m Unit
debounce ms key make cache run = do
  avar ← laterVar ms $ void $ run *> Cache.remove key cache
  Cache.alter key (alterFn (make avar)) cache
  where
    alterFn a b = fromAff do
      traverse_ (flip killVar (Exn.error "debounce") ∘ _.avar) b
        $> Just a

liftWithErr ∷ ∀ m a. Monad m ⇒ String → m (Maybe a) → ExceptT QE.QError m a
liftWithErr err =
  maybe (QE.throw err) pure <=< lift

updateCellModel ∷ CM.AnyCardModel → Card.Cell → Card.Cell
updateCellModel model cell = cell
  { value = cell.value
      { model = cell.value.model
          { model = model
          }
      }
  }

{-
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.Eval.Persistence where

import SlamData.Prelude

import Control.Monad.Aff.AVar (AVar, takeVar, putVar, modifyVar, killVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Aff.Promise (wait, defer)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Fork (class MonadFork, fork)
import Control.Parallel (parSequence)

import Data.Array as Array
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Rational ((%))

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Data as Quasar
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.AccessType (isEditable)
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Eval as Eval
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Deck as Deck
import SlamData.Workspace.Eval.Graph (unfoldGraph, EvalGraph)
import SlamData.Workspace.Model as WM
import SlamData.Wiring (Wiring)
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache

import Utils (censor)
import Utils.Aff (laterVar)

defaultSaveDebounce ∷ Int
defaultSaveDebounce = 500

defaultEvalDebounce ∷ Int
defaultEvalDebounce = 500

type Persist f m a =
  ( Affable SlamDataEffects m
  , MonadAsk Wiring m
  , MonadFork Exn.Error m
  , Parallel f m
  , QuasarDSL m
  ) ⇒ a

putDeck ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
putDeck deckId deck = do
  { path, eval, accessType } ← Wiring.expose
  ref ← defer do
    res ←
      if isEditable accessType
        then Quasar.save (Deck.deckIndex path deckId) $ Deck.encode deck
        else pure (Right unit)
    pure $ res $> deck
  Cache.alter deckId (updateOrFork ref) eval.decks
  rmap (const unit) <$> wait ref
  where
    updateOrFork ref = case _ of
      Just cell →
        pure $ Just cell
          { value = ref
          , model = deck
          }
      Nothing → do
        cell ← { value: ref, model: deck, bus: _ } <$> fromAff Bus.make
        fork do
          populateCards deckId deck
          forkDeckProcess deckId cell.bus
        pure (Just cell)

saveDeck ∷ ∀ f m. Persist f m (Deck.Id → m Unit)
saveDeck deckId = do
  { eval } ← Wiring.expose
  newDeck ← runMaybeT do
    cell ← MaybeT $ Cache.get deckId eval.decks
    deck ← MaybeT $ censor <$> wait cell.value
    cards ← MaybeT $ sequence <$> traverse getCard (Tuple deckId ∘ _.cardId <$> deck.cards)
    pure deck { cards = (\c → c.value.model) <$> cards }
  for_ newDeck (void ∘ putDeck deckId)

-- | Loads a deck from a DeckId. Returns the model.
getDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Model))
getDeck =
  getDeck' >=> _.value >>> wait

-- | Loads a deck from a DeckId. This has the effect of loading decks from
-- | which it extends (for mirroring) and populating the card graph. Returns
-- | the "cell" (model promise paired with its message bus).
getDeck' ∷ ∀ f m. Persist f m (Deck.Id → m Deck.Cell)
getDeck' deckId = do
  { path, eval } ← Wiring.expose
  let
    cacheVar = Cache.unCache eval.decks
  decks ← fromAff (takeVar cacheVar)
  case Map.lookup deckId decks of
    Just cell → do
      fromAff $ putVar cacheVar decks
      pure cell
    Nothing → do
      value ← defer do
        let
          deckPath = Deck.deckIndex path deckId
        -- FIXME: Notify on failure
        result ← runExceptT do
          deck ← ExceptT $ (_ >>= Deck.decode >>> lmap QE.msgToQError) <$> Quasar.load deckPath
          _    ← ExceptT $ populateCards deckId deck
          pure deck
        case result of
          Left _ →
            fromAff $ modifyVar (Map.delete deckId) cacheVar
          Right model →
            Cache.alter deckId (pure ∘ map (_ { model = model })) eval.decks
        pure result
      cell ← { value, model: Deck.emptyDeck, bus: _ } <$> fromAff Bus.make
      fromAff do
        putVar cacheVar (Map.insert deckId cell decks)
      forkDeckProcess deckId cell.bus
      pure cell

-- | Populates the card eval graph based on a deck model. This may fail as it
-- | also attempts to load/hydrate foreign cards (mirrors) as well.
populateCards ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
populateCards deckId deck = runExceptT do
  { eval } ← Wiring.expose
  decks ←
    ExceptT $ sequence <$>
      parTraverse getDeck (Array.nub (fst <$> deck.mirror))
  let
    cards = List.fromFoldable deck.cards
  case Array.last deck.mirror of
    Nothing → lift $ threadCards eval.cards cards
    Just coord → do
      cell ← do
        mb ← Cache.get coord eval.cards
        case mb of
          Nothing → QE.throw ("Card not found in eval cache: " <> show coord)
          Just a  → pure a
      let
        next = case List.head cards of
          Nothing → Left deckId
          Just c  → Right (deckId × c.cardId)
        cell' = cell { next = next : cell.next }
      Cache.put coord cell' eval.cards
      lift $ threadCards eval.cards cards
  where
    threadCards cache = case _ of
      Nil         → pure unit
      c : Nil     → makeCell c Nil cache
      c : c' : cs → do
        makeCell c (pure c'.cardId) cache
        threadCards cache (c' : cs)

    makeCell card next cache = do
      let
        coord = deckId × card.cardId
      cell ← makeCardCell card Nothing (Right ∘ Tuple deckId <$> next)
      Cache.put coord cell cache
      forkCardProcess coord cell.bus

-- FIXME: Maybe we don't need this, we can just call all these directly.
forkDeckProcess ∷ ∀ f m . Persist f m (Deck.Id → Bus.BusRW Deck.EvalMessage → m Unit)
forkDeckProcess deckId = forkLoop case _ of
  Deck.Force source →
    queueEval' 0 source
  Deck.AddCard cty →
    addCard deckId cty >>= traverse_ \coord → do
      queueSave defaultSaveDebounce deckId
      queueEval' 0 (mempty × coord)
  Deck.RemoveCard coord → do
    removeCard deckId coord >>= traverse_ \_ → do
      queueSave defaultSaveDebounce deckId
  Deck.UpdateParent parent → do
    { eval } ← Wiring.expose
    deckCell ← getDeck' deckId
    mbDeck ← wait deckCell.value
    for_ mbDeck \deck → do
      let
        deck' = deck { parent = parent }
      value' ← defer (pure (Right deck'))
      Cache.put deckId (deckCell { value = value' }) eval.decks
      queueSave defaultSaveDebounce deckId
  _ →
    pure unit

forkCardProcess ∷ ∀ f m. Persist f m (Card.Coord → Bus.BusRW Card.EvalMessage → m Unit)
forkCardProcess coord@(deckId × cardId) = forkLoop case _ of
  Card.ModelChange source model → do
    { eval } ← Wiring.expose
    Cache.alter coord (pure ∘ map (updateCellModel model)) eval.cards
    mbGraph ← snapshotGraph coord
    for_ mbGraph \graph → do
      queueSave defaultSaveDebounce deckId
      queueEval defaultEvalDebounce source graph
  _ →
    pure unit

snapshotGraph ∷ ∀ f m. Persist f m (Card.Coord → m (Maybe EvalGraph))
snapshotGraph coord = do
  { eval } ← Wiring.expose
  unfoldGraph
    <$> Cache.snapshot eval.cards
    <*> Cache.snapshot eval.decks
    <*> pure coord

queueSave ∷ ∀ f m. Persist f m (Int → Deck.Id → m Unit)
queueSave ms deckId = do
  { eval } ← Wiring.expose
  debounce ms deckId { avar: _ } eval.pendingSaves do
    saveDeck deckId

queueEval ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → EvalGraph → m Unit)
queueEval ms source@(_ × coord) graph = do
  { eval } ← Wiring.expose
  let
    pending =
      { source
      , graph
      , avar: _
      }
  -- TODO: Notify pending immediately
  debounce ms coord pending eval.pendingEvals do
    Eval.evalGraph source graph

queueEval' ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → m Unit)
queueEval' ms source@(_ × coord) =
  traverse_ (queueEval ms source) =<< snapshotGraph coord

freshWorkspace ∷ ∀ f m. Persist f m (m (Deck.Id × Deck.Cell))
freshWorkspace = do
  { eval } ← Wiring.expose
  rootId ← fromAff DID.make
  bus ← fromAff Bus.make
  value ← defer (pure (Right Deck.emptyDeck))
  let
    cell = { bus, value, model: Deck.emptyDeck }
  Cache.put rootId cell eval.decks
  forkDeckProcess rootId bus
  pure (rootId × cell)

wrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    parentDeck = DM.wrappedDeck deck.parent (snd parentCoord) deckId
  ExceptT $ putDeck (fst parentCoord) parentDeck
  ExceptT $ updateParentPointer deckId (fst parentCoord) deck.parent
  fromAff $ Bus.write (Deck.UpdateParent (Just parentCoord)) cell.bus
  pure (fst parentCoord)

wrapAndMirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapAndMirrorDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    wrappedDeck =
      DM.splitDeck deck.parent (snd parentCoord) Orn.Vertical
        (List.fromFoldable [ deckId, newMirrorId ])
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { parent = Just parentCoord }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          , updateParentPointer deckId (fst parentCoord) deck.parent
          ]
      else do
        let
          oldCardIds = Tuple deckId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just parentCoord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          , updateParentPointer deckId (fst parentCoord) deck.parent
          ]
  lift $ relocateCardsTo newSharedId deckId (_.cardId <$> deck.cards)
  pure (fst parentCoord)

mirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Deck.Id))
mirrorDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  parent ← liftWithErr "Parent not found." $ getCard coord
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { name = "" }
        parSequence
          [ putDeck newMirrorId mirrored
          ]
      else do
        let
          oldCardIds = Tuple childId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just coord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        parSequence
          [ putDeck childId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          ]
  lift $ relocateCardsTo newSharedId childId (_.cardId <$> deck.cards)
  parent'' ← liftWithErr "Cannot mirror deck." $ pure $ mirrorInLayout newMirrorId parent.value.model.model
  fromAff $ Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  pure newMirrorId
  where
  mirrorInLayout newId = case _ of
    CM.Draftboard { layout } → do
      cursor ← List.tail =<< Pane.getCursorFor (Just childId) layout
      let
        orn =
          case Pane.getAt cursor layout of
            Just (Pane.Split o _) → o
            _ → Orn.Vertical
      layout' ←
        Layout.insertSplit
          (Pane.Cell (Just newId)) orn (1%2) Layout.SideB cursor layout
      pure (CM.Draftboard { layout: layout' })
    _ →
      Nothing

unwrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
unwrapDeck deckId = runExceptT do
  deck ← ExceptT $ getDeck deckId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords deckId deck)
  childId ← liftWithErr "Cannot unwrap deck." $ pure $ immediateChild (_.value.model.model ∘ snd <$> cards)
  cell ← lift $ getDeck' childId
  ExceptT $ updateParentPointer deckId childId deck.parent
  fromAff $ Bus.write (Deck.UpdateParent deck.parent) cell.bus
  pure childId
  where
    immediateChild = case _ of
      [ model ] →
        case CM.childDeckIds model of
          childId : Nil → Just childId
          _ → Nothing
      _ → Nothing

collapseDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
collapseDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords childId deck)
  parent ← liftWithErr "Parent not found." $ getCard coord
  let
    parent' = parent.value.model.model
    cards' = _.value.model.model ∘ snd <$> cards
  childIds × parent'' ← liftWithErr "Cannot collapse deck." $ pure $ collapsed parent' cards'
  childDecks ← lift $ traverse getDeck' childIds
  fromAff do
    for_ childDecks \{ bus } →
      Bus.write (Deck.UpdateParent (Just coord)) bus
    Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  where
    collapsed parent child = case parent, child of
      CM.Draftboard { layout }, [ cm@CM.Draftboard { layout: subLayout } ] → do
        cursor ← Pane.getCursorFor (Just childId) layout
        layout' ← Pane.modifyAt (const subLayout) cursor layout
        let
          childIds = CM.childDeckIds cm
          parent' = CM.Draftboard { layout: layout' }
        pure (childIds × parent')
      _, _ →
        Nothing

addCard ∷ ∀ f m. Persist f m (Deck.Id → CT.CardType → m (Either QE.QError Card.Coord))
addCard deckId cty = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  cardId ← fromAff CID.make
  let
    coord = deckId × cardId
  lift do
    input ← runMaybeT do
      last ← MaybeT $ pure $ Array.last (Deck.cardCoords deckId deck)
      cell ← MaybeT $ Cache.get last eval.cards
      let
        next' = List.filter (not ∘ eq (Left deckId)) cell.next
        cell' = cell { next = Right coord : next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    let
      card = { cardId, model: Card.cardModelOfType (fromMaybe Port.Initial input) cty }
      deck' = deck { cards = Array.snoc deck.cards card }
    cell ← makeCardCell card input mempty
    value' ← defer (pure (Right deck'))
    Cache.put (deckId × cardId) cell eval.cards
    Cache.put deckId (deckCell { value = value' }) eval.decks
    forkCardProcess coord cell.bus
    pure coord

removeCard ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
removeCard deckId coord@(deckId' × cardId) = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  lift do
    let
      coords = Array.span (not ∘ eq coord) (Deck.cardCoords deckId deck)
      deck' =
        if deckId ≡ deckId'
          then deck { cards = Array.takeWhile (not ∘ eq cardId ∘ _.cardId) deck.cards }
          else deck { cards = [], mirror = Array.takeWhile (not ∘ eq coord) deck.mirror }
    output ← runMaybeT do
      last ← MaybeT $ pure $ Array.last coords.init
      cell ← MaybeT $ Cache.get last eval.cards
      let
        leaf = if Array.null deck'.cards then pure (Left deckId) else mempty
        next' = List.delete (Right coord) cell.next
        cell' = cell { next = leaf <> next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    value' ← defer (pure (Right deck'))
    Cache.put deckId (deckCell { value = value' }) eval.decks
    fromAff $ Bus.write (Deck.Complete coords.init (fromMaybe Port.Initial output)) deckCell.bus

updateParentPointer
  ∷ ∀ f m
  . Persist f m
  ( Deck.Id
  → Deck.Id
  → Maybe Card.Coord
  → m (Either QE.QError Unit) )
updateParentPointer oldId newId parent =
  runExceptT case parent of
    Just coord@(deckId × cardId) → do
      -- We need to guard on the parentDeck because it may not be loaded if we
      -- are viewing the child at the root of the UI.
      parentDeck ← ExceptT $ getDeck deckId
      cell ← getCard coord
      for_ cell \{ bus, value } → do
        let
          model' = CM.updatePointer oldId (Just newId) value.model.model
          message = Card.ModelChange (Card.toAll coord) model'
        fromAff $ Bus.write message bus
    Nothing → do
      { path } ← Wiring.expose
      ExceptT $ WM.setRoot (path </> Pathy.file "index") newId

relocateCardsTo ∷ ∀ f m . Persist f m (Deck.Id → Deck.Id → Array Card.Id → m Unit)
relocateCardsTo deckId oldDeckId coords = do
  { eval } ← Wiring.expose
  cards ← getCards (Tuple oldDeckId <$> coords)
  for_ cards (go eval.cards ∘ List.fromFoldable ∘ map snd)
  where
    go cache = case _ of
      c : Nil → do
        let
          cardId = c.value.model.cardId
          coord = deckId × cardId
          next = Left oldDeckId : c.next
        fromAff $ Bus.kill (Exn.error "Relocated") c.bus
        Cache.remove (oldDeckId × cardId) cache
        Cache.alter coord
          (pure ∘ map \c' → c' { value = c.value, next = Left oldDeckId : c'.next })
          cache
      c1 : c2 : cs → do
        let
          cardId1 = c1.value.model.cardId
          cardId2 = c2.value.model.cardId
          coord2 = oldDeckId × cardId2
          coord = deckId × cardId1
          updateNext = map (map \c → if c ≡ coord2 then deckId × cardId2 else c)
        fromAff $ Bus.kill (Exn.error "Relocated") c1.bus
        Cache.remove (oldDeckId × cardId1) cache
        Cache.alter coord
          (pure ∘ map \c' → c' { value = c1.value, next = updateNext c'.next })
          cache
        go cache (c2 : cs)
      Nil →
        pure unit

forkLoop
  ∷ ∀ m r a
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    )
  ⇒ (a → m Unit)
  → Bus.Bus (Bus.R' r) a
  → m Unit
forkLoop handler bus = void (fork loop)
  where
    loop = do
      msg ← fromAff (Bus.read bus)
      fork (handler msg)
      loop

makeCardCell
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , Monad m
    )
  ⇒ Card.Model
  → Maybe Port
  → List (Either Deck.Id Card.Coord)
  → m Card.Cell
makeCardCell model input next = do
  let
    value ∷ Card.EvalResult
    value =
      { model
      , input
      , output: Nothing
      , state: Nothing
      , sources: mempty
      , tick: Nothing
      }
  bus ← fromAff Bus.make
  pure { bus, next, value }

getCard
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Card.Coord
  → m (Maybe Card.Cell)
getCard coord = do
  { eval } ← Wiring.expose
  Cache.get coord eval.cards

getCards
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Array Card.Coord
  → m (Maybe (Array (Deck.Id × Card.Cell)))
getCards = map sequence ∘ traverse go
  where
    go coord = map (fst coord × _) <$> getCard coord

debounce
  ∷ ∀ k m r
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    , Ord k
    )
  ⇒ Int
  → k
  → (AVar Unit → { avar ∷ AVar Unit | r })
  → Cache.Cache k { avar ∷ AVar Unit | r }
  → m Unit
  → m Unit
debounce ms key make cache run = do
  avar ← laterVar ms $ void $ run *> Cache.remove key cache
  Cache.alter key (alterFn (make avar)) cache
  where
    alterFn a b = fromAff do
      traverse_ (flip killVar (Exn.error "debounce") ∘ _.avar) b
        $> Just a

liftWithErr ∷ ∀ m a. Monad m ⇒ String → m (Maybe a) → ExceptT QE.QError m a
liftWithErr err =
  maybe (QE.throw err) pure <=< lift

updateCellModel ∷ CM.AnyCardModel → Card.Cell → Card.Cell
updateCellModel model cell = cell
  { value = cell.value
      { model = cell.value.model
          { model = model
          }
      }
  }


Set overwrites existing child

Set overwrites existing child

module Test.Main where

import Prelude (Unit, bind, ($), (>>=))

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Either (Either(Right))
import Web.Firebase as FB
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, pending, it)
import Test.Spec.Runner           (Process(), run)
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import PlayWithFire (readSuccessAff, Success(Success), snapshot2success)
import Web.Firebase.Monad.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Data.Foreign as F

getRoot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
getRoot = refFor "https://purescript-spike.firebaseio.com/"

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries"

rootSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
rootSnapshot = getRoot >>= onceValue

entriesSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
entriesSnapshot = getRoot >>= \r -> (liftEff $ FB.child "entries" r) >>= onceValue

readRootChild :: String -> forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
readRootChild location = getRoot >>= childAt >>= readSuccessAff
  where
    childAt ref = liftEff $ FB.child location ref

getYes :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
getYes = readRootChild "entries/-K7GbWeFHfJXlun7szRe"

-- Reading non-existant data will just wait forever
-- because it might exist in the future?
-- can only be tested with a timeout?
childAddedError :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
childAddedError = readRootChild "doesnotexist"

main ::  forall eff. Eff ( console :: CONSOLE, process :: Process, firebase :: FBT.FirebaseEff | eff) Unit
main = run [consoleReporter] do
  describe "Firebase" do
    describe "Reading once" do
      it "delivers a child when added" do
        success <- getYes
        success `shouldEqual` (Right (Success {success: "yes!"}))

      pending "delivers a value when asked"
      pending "can check for the existence of a chile of a firebase ref"

    describe "DataSnapshot" do
      -- literal API
      -- the difference between snapshots and refs is somewhat confusing
      it "can tell us the number of children" do
	rs <- rootSnapshot
	let numChildren = D.numChildren rs
        numChildren `shouldEqual` 1
      it "can tell us a child does not exist" do
	rs <- rootSnapshot
	let noChild = D.hasChild rs "doesnotexist"
	noChild `shouldEqual` false
      it "can tell us a child exists" do
	rs <- rootSnapshot
	let childExists = D.hasChild rs "entries" -- type Key = String ?
	childExists `shouldEqual` true
      it "can tell us the location at the snapshot exists" do
	rs <- rootSnapshot
        let rootExists = D.exists rs
	rootExists `shouldEqual` true
      it "can tell us it has children" do
        rs <- rootSnapshot
        let hasChildren = D.hasChildren rs
        hasChildren `shouldEqual` true

      it "says the key of the database root is Nothing" do
        rs <- rootSnapshot
        let key = D.key rs
        key `shouldEqual` Nothing

      it "says the key of /entries is entries" do
        sn <- entriesSnapshot
        let key = D.key sn
        key `shouldEqual` (Just "entries")

      pending "it can not tell us the location at the snapshot does not exist"
      pending "can it say the value of child \"entries\" is Nothing?"
        -- this relies on trying to read a firebase ref with once, and that 'works' by never being called back
      pending "it can give us a snapshot of one of its children"
      -- implement forEach callback that returns true after first call, so it terminates
      -- put that callback into Aff, so we can wait for the result
      -- with Aff, and the Aff variable, we can retrieve a list.
    describe "Authorization" do
	 {- https://www.firebase.com/docs/web/guide/user-auth.html#section-handling-errors:
  All errors are Error objects containing at least code and message attributes. In some cases, additional information will be provided via the details attribute. For example:
  {
	    code: "TRANSPORT_UNAVAILABLE",
       message: "There are no login transports available for the requested method.",
         details: "More details about the specific error here."
 }
	-}
      pending "returns an error object subscribing to an unauthorized location"
      -- this forces us to handle errors in Aff, and parse Error objects
      -- as well as placing some authorization rules in Firebase
      -- documentation on firebase Error was hard to find, having an actual one would allow us to write some marshalling code. code and message should be present, details wrapped in a Maybe. Given we don't own this interface, placing a console.log in the FFi javascript side is wise for now.
  describe "Writing" do
      it "can add an item to a list" do
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "random numbered string"}) Nothing location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        -- key is different on every write. Checking unique keys is work for QuickCheck
        (snapshot2success snap) `shouldEqual` (Right (Success {success: "random numbered string"}))
        -- use key to read value

      it "can overwrite an existing item" do
        let secondValue = {success: "second value"}
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "initial value"}) Nothing location
        _ <- liftEff $ FB.set (F.toForeign $ secondValue) Nothing newChildRef
        snap <- onceValue newChildRef
        (snapshot2success snap) `shouldEqual` (Right (Success secondValue))

      pending "can overwrite an existing item in Aff"
      pending "can add a server-side timestamp to new items"
      pending "push Aff when writing to non-existant location returns an error"
      -- implement AFF with error callback (it is error object or nothing, so we can make it 'or Right "write successful", which we can reuse in a value writeSuccess so we can assert against that. Not sure how to combine that with the value of the key that is also returned from the js function'

module Test.Main where

import Prelude (Unit, bind, ($), (>>=))

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Either (Either(Right))
import Web.Firebase as FB
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, pending, it)
import Test.Spec.Runner           (Process(), run)
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import PlayWithFire (readSuccessAff, Success(Success), snapshot2success)
import Web.Firebase.Monad.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Data.Foreign as F

getRoot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
getRoot = refFor "https://purescript-spike.firebaseio.com/"

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries"

rootSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
rootSnapshot = getRoot >>= onceValue

entriesSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
entriesSnapshot = getRoot >>= \r -> (liftEff $ FB.child "entries" r) >>= onceValue

readRootChild :: String -> forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
readRootChild location = getRoot >>= childAt >>= readSuccessAff
  where
    childAt ref = liftEff $ FB.child location ref

getYes :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
getYes = readRootChild "entries/-K7GbWeFHfJXlun7szRe"

-- Reading non-existant data will just wait forever
-- because it might exist in the future?
-- can only be tested with a timeout?
childAddedError :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) (Either String Success)
childAddedError = readRootChild "doesnotexist"

main ::  forall eff. Eff ( console :: CONSOLE, process :: Process, firebase :: FBT.FirebaseEff | eff) Unit
main = run [consoleReporter] do
  describe "Firebase" do
    describe "Reading once" do
      it "delivers a child when added" do
        success <- getYes
        success `shouldEqual` (Right (Success {success: "yes!"}))

      pending "delivers a value when asked"
      pending "can check for the existence of a chile of a firebase ref"

    describe "DataSnapshot" do
      -- literal API
      -- the difference between snapshots and refs is somewhat confusing
      it "can tell us the number of children" do
	rs <- rootSnapshot
	let numChildren = D.numChildren rs
        numChildren `shouldEqual` 1
      it "can tell us a child does not exist" do
	rs <- rootSnapshot
	let noChild = D.hasChild rs "doesnotexist"
	noChild `shouldEqual` false
      it "can tell us a child exists" do
	rs <- rootSnapshot
	let childExists = D.hasChild rs "entries" -- type Key = String ?
	childExists `shouldEqual` true
      it "can tell us the location at the snapshot exists" do
	rs <- rootSnapshot
        let rootExists = D.exists rs
	rootExists `shouldEqual` true
      it "can tell us it has children" do
        rs <- rootSnapshot
        let hasChildren = D.hasChildren rs
        hasChildren `shouldEqual` true

      it "says the key of the database root is Nothing" do
        rs <- rootSnapshot
        let key = D.key rs
        key `shouldEqual` Nothing

      it "says the key of /entries is entries" do
        sn <- entriesSnapshot
        let key = D.key sn
        key `shouldEqual` (Just "entries")

      pending "it can not tell us the location at the snapshot does not exist"
      pending "can it say the value of child \"entries\" is Nothing?"
        -- this relies on trying to read a firebase ref with once, and that 'works' by never being called back
      pending "it can give us a snapshot of one of its children"
      -- implement forEach callback that returns true after first call, so it terminates
      -- put that callback into Aff, so we can wait for the result
      -- with Aff, and the Aff variable, we can retrieve a list.
    describe "Authorization" do
	 {- https://www.firebase.com/docs/web/guide/user-auth.html#section-handling-errors:
  All errors are Error objects containing at least code and message attributes. In some cases, additional information will be provided via the details attribute. For example:
  {
	    code: "TRANSPORT_UNAVAILABLE",
       message: "There are no login transports available for the requested method.",
         details: "More details about the specific error here."
 }
	-}
      pending "returns an error object subscribing to an unauthorized location"
      -- this forces us to handle errors in Aff, and parse Error objects
      -- as well as placing some authorization rules in Firebase
      -- documentation on firebase Error was hard to find, having an actual one would allow us to write some marshalling code. code and message should be present, details wrapped in a Maybe. Given we don't own this interface, placing a console.log in the FFi javascript side is wise for now.
  describe "Writing" do
      it "can add an item to a list" do
        -- see writeWithFire (or rather: addWithFire)
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "random numbered string"}) Nothing location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        -- key is different on every write. Checking unique keys is work for QuickCheck
        (snapshot2success snap) `shouldEqual` (Right (Success {success: "random numbered string"}))
        -- use key to read value

      pending "can overwrite a (possibly) existing item"
      pending "can add a server-side timestamp to new items"


remove extra ()

remove extra ()

module Test.Spec.Tree
  ( Tree(..)
  , Item(..)
  , ActionWith
  , bimapTree
  , countTests
  , isAllParallelizable
  , discardUnfocused
  , modifyAroundAction
  , PathItem(..)
  , Path
  , parentSuiteName
  , parentSuite
  ) where

import Prelude

import Control.Monad.State (execState)
import Control.Monad.State as State
import Data.Array (mapMaybe, snoc, unsnoc)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Bifunctor (class Bifunctor)
import Data.Either (Either, either)
import Data.Foldable (class Foldable, all, foldMapDefaultL, foldl, foldr)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, un)
import Data.Traversable (for, for_)
import Data.Tuple (Tuple(..))

data Tree c a
  = Node (Either String c) (Array (Tree c a))
  | Leaf String (Maybe a)

instance showGroup :: (Show c, Show a) => Show (Tree c a) where
  show (Node nc xs) = "(Node " <> show nc <> " " <> show xs <> ")"
  show (Leaf name t) = "(Leaf " <> show name <> " " <> show t <> ")"

instance eqGroup :: (Eq c, Eq a) => Eq (Tree c a) where
  eq (Node nc1 xs1) (Node nc2 xs2) = nc1 == nc2 && xs1 == xs2
  eq (Leaf n1 t1) (Leaf n2 t2) = n1 == n2 && t1 == t2
  eq _                    _                    = false

bimapTree :: forall a b c d. (Array String -> a -> b) -> (NonEmptyArray String ->c -> d) -> Tree a c -> Tree b d
bimapTree g f = go []
  where
    go :: Array String -> Tree a c -> Tree b d
    go namePath spec = case spec of
      Node d xs ->
        let namePath' = either (snoc namePath) (const namePath) d
        in Node (map (g namePath') d) (map (go namePath') xs)
      Leaf n item -> Leaf n (map (f $ NEA.snoc' namePath n) item)

instance treeBifunctor :: Bifunctor Tree where
  bimap g f = bimapTree (const g) (const f)

instance treeFoldable :: Foldable (Tree c) where
  foldr f i (Leaf _ a) = maybe i (\a' -> f a' i) a
  foldr f i (Node _ as) = foldr (\a i' -> foldr f i' a) i as
  foldl f i (Leaf _ a) = maybe i (\a' -> f i a') a
  foldl f i (Node _ as) = foldl (\i' a -> foldl f i' a) i as
  foldMap f = foldMapDefaultL f

type ActionWith m a = a -> m Unit

newtype Item m a = Item
  { isFocused :: Boolean
  , isParallelizable :: Maybe Boolean
  , example :: (ActionWith m a -> m Unit) -> m Unit
  }

derive instance itemNewtype :: Newtype (Item m a) _

instance itemShow :: Show (Item m a) where
  show (Item {isFocused, isParallelizable}) =
    "Item (" <> show {isFocused, isParallelizable, example: "Function"} <> ")"

instance itemEq :: Eq (Item m a) where
  eq (Item a) (Item b) =
    a.isFocused == b.isFocused && a.isParallelizable == b.isParallelizable

-- | Count the total number of tests in a spec
countTests :: forall c t. Array (Tree c t) -> Int
countTests g = execState (for g go) 0
  where
  go (Node _ xs) = for_ xs go
  go (Leaf _ _) = State.modify_ (_ + 1)

-- | Return true if all items in the tree are parallelizable
isAllParallelizable :: forall c m a. Tree c (Item m a) -> Boolean
isAllParallelizable = case _ of
  Node _ xs -> all isAllParallelizable xs
  Leaf _ x -> x == Nothing || (x >>= un Item >>> _.isParallelizable) == Just true

-- | If there is at least one focused element, all paths which don't
-- | lead to a focused element will be remove. otherwise input will
-- | be returned as unchanged.
discardUnfocused :: forall c m a. Array (Tree c (Item m a)) -> Array (Tree c (Item m a))
discardUnfocused ts = case mapMaybe findFocus ts of
  [] -> ts
  r -> r
  where
  findFocus :: Tree c (Item m a) -> Maybe (Tree c (Item m a))
  findFocus (Node n ts') = case mapMaybe findFocus ts' of
    [] -> Nothing
    r -> Just $ Node n r
  findFocus t@(Leaf n (Just (Item { isFocused }))) = if isFocused then Just t else Nothing
  findFocus (Leaf n Nothing) = Nothing

-- | Modify around action of an Item
modifyAroundAction :: forall g a b. (ActionWith g a -> ActionWith g b) -> Item g a -> Item g b
modifyAroundAction action (Item item) = Item $ item
  { example = \aroundAction -> item.example (aroundAction <<< action)
  }

newtype PathItem = PathItem { index :: Int, name :: Maybe String }

derive instance newtypePathItem :: Newtype PathItem _
derive newtype instance showIdTerm :: Show PathItem
derive newtype instance pathItemEq :: Eq PathItem
derive newtype instance pathItemOrd :: Ord PathItem

type Path = Array PathItem

parentSuiteName :: Path -> Array String
parentSuiteName = mapMaybe (un PathItem >>> _.name)

parentSuite :: Path -> Maybe { path :: Path, name :: String }
parentSuite = flip foldr Nothing case _, _ of
  PathItem {name: Just name}, Nothing -> Just {path: [], name}
  PathItem {name: Nothing}, Nothing -> Nothing
  p, Just acc -> Just acc{path = [p] <> acc.path}

module Test.Spec.Tree
  ( Tree(..)
  , Item(..)
  , ActionWith
  , bimapTree
  , countTests
  , isAllParallelizable
  , discardUnfocused
  , modifyAroundAction
  , PathItem(..)
  , Path
  , parentSuiteName
  , parentSuite
  ) where

import Prelude

import Control.Monad.State (execState)
import Control.Monad.State as State
import Data.Array (mapMaybe, snoc, unsnoc)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Bifunctor (class Bifunctor)
import Data.Either (Either, either)
import Data.Foldable (class Foldable, all, foldMapDefaultL, foldl, foldr)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, un)
import Data.Traversable (for, for_)
import Data.Tuple (Tuple(..))

data Tree c a
  = Node (Either String c) (Array (Tree c a))
  | Leaf String (Maybe a)

instance showGroup :: (Show c, Show a) => Show (Tree c a) where
  show (Node nc xs) = "(Node " <> show nc <> " " <> show xs <> ")"
  show (Leaf name t) = "(Leaf " <> show name <> " " <> show t <> ")"

instance eqGroup :: (Eq c, Eq a) => Eq (Tree c a) where
  eq (Node nc1 xs1) (Node nc2 xs2) = nc1 == nc2 && xs1 == xs2
  eq (Leaf n1 t1) (Leaf n2 t2) = n1 == n2 && t1 == t2
  eq _                    _                    = false

bimapTree :: forall a b c d. (Array String -> a -> b) -> (NonEmptyArray String ->c -> d) -> Tree a c -> Tree b d
bimapTree g f = go []
  where
    go :: Array String -> Tree a c -> Tree b d
    go namePath spec = case spec of
      Node d xs ->
        let namePath' = either (snoc namePath) (const namePath) d
        in Node (map (g namePath') d) (map (go namePath') xs)
      Leaf n item -> Leaf n (map (f $ NEA.snoc' namePath n) item)

instance treeBifunctor :: Bifunctor Tree where
  bimap g f = bimapTree (const g) (const f)

instance treeFoldable :: Foldable (Tree c) where
  foldr f i (Leaf _ a) = maybe i (\a' -> f a' i) a
  foldr f i (Node _ as) = foldr (\a i' -> foldr f i' a) i as
  foldl f i (Leaf _ a) = maybe i (\a' -> f i a') a
  foldl f i (Node _ as) = foldl (\i' a -> foldl f i' a) i as
  foldMap f = foldMapDefaultL f

type ActionWith m a = a -> m Unit

newtype Item m a = Item
  { isFocused :: Boolean
  , isParallelizable :: Maybe Boolean
  , example :: (ActionWith m a -> m Unit) -> m Unit
  }

derive instance itemNewtype :: Newtype (Item m a) _

instance itemShow :: Show (Item m a) where
  show (Item {isFocused, isParallelizable}) =
    "Item (" <> show {isFocused, isParallelizable, example: "Function"} <> ")"

instance itemEq :: Eq (Item m a) where
  eq (Item a) (Item b) =
    a.isFocused == b.isFocused && a.isParallelizable == b.isParallelizable

-- | Count the total number of tests in a spec
countTests :: forall c t. Array (Tree c t) -> Int
countTests g = execState (for g go) 0
  where
  go (Node _ xs) = for_ xs go
  go (Leaf _ _) = State.modify_ (_ + 1)

-- | Return true if all items in the tree are parallelizable
isAllParallelizable :: forall c m a. Tree c (Item m a) -> Boolean
isAllParallelizable = case _ of
  Node _ xs -> all isAllParallelizable xs
  Leaf _ (x) -> x == Nothing || (x >>= un Item >>> _.isParallelizable) == Just true

-- | If there is at least one focused element, all paths which don't
-- | lead to a focused element will be remove. otherwise input will
-- | be returned as unchanged.
discardUnfocused :: forall c m a. Array (Tree c (Item m a)) -> Array (Tree c (Item m a))
discardUnfocused ts = case mapMaybe findFocus ts of
  [] -> ts
  r -> r
  where
  findFocus :: Tree c (Item m a) -> Maybe (Tree c (Item m a))
  findFocus (Node n ts') = case mapMaybe findFocus ts' of
    [] -> Nothing
    r -> Just $ Node n r
  findFocus t@(Leaf n (Just (Item { isFocused }))) = if isFocused then Just t else Nothing
  findFocus (Leaf n Nothing) = Nothing

-- | Modify around action of an Item
modifyAroundAction :: forall g a b. (ActionWith g a -> ActionWith g b) -> Item g a -> Item g b
modifyAroundAction action (Item item) = Item $ item
  { example = \aroundAction -> item.example (aroundAction <<< action)
  }

newtype PathItem = PathItem { index :: Int, name :: Maybe String }

derive instance newtypePathItem :: Newtype PathItem _
derive newtype instance showIdTerm :: Show PathItem
derive newtype instance pathItemEq :: Eq PathItem
derive newtype instance pathItemOrd :: Ord PathItem

type Path = Array PathItem

parentSuiteName :: Path -> Array String
parentSuiteName = mapMaybe (un PathItem >>> _.name)

parentSuite :: Path -> Maybe { path :: Path, name :: String }
parentSuite = flip foldr Nothing case _, _ of
  PathItem {name: Just name}, Nothing -> Just {path: [], name}
  PathItem {name: Nothing}, Nothing -> Nothing
  p, Just acc -> Just acc{path = [p] <> acc.path}


Make addColumn compile again

Make addColumn compile again

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Tab
  ( Cell
  , Col
  , class ColType
  , kindOf
  , Tab
  , addColumn
  -- , addRow
  , empty
  , createColumn
  ) where

import Data.List
import Data.Vec
import Prelude

import Data.Maybe (Maybe(..))
import Data.Typelevel.Bool (True)
import Data.Typelevel.Num (class Nat, class Succ, D0)
import Data.Vec (empty, snoc) as Vec
import HList (HList(..), cons)
import HList as HList
import Partial.Unsafe (unsafePartial)

newtype Col x = Col
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kindOf :: Col a -> String

instance stringCol :: ColType String where
  kindOf c = "String"
instance intCol :: ColType Int where
  kindOf c = "Int"

instance showStringCol :: Show (Col String) where
  show (col@Col c) = "Column(" <> show c.id <> ", " <> c.name <> ", " <> kindOf col <> ")"

createColumn :: forall x. ColType x => x -> Int -> String -> Col x
createColumn colTypeTag id name = Col
  { id : id
  , name : name
  , kind : colTypeTag
  }

-- TODO Removes all rows for now to get it working at all...
addColumn :: forall a b l. Tab a l -> Col b -> Tab (Col b) (HList a l)
addColumn (Tab tab) col = Tab
  { columns: HList.cons col tab.columns
  , rows: Nil
  }

type Cell a = Maybe a

type Cells l = forall a. HList a l

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab head tail = Tab
  { columns :: HList head tail
  , rows :: List (HList (Cell head) (Cells tail)) -- something like (ToRowMap head) (ToRowMap tail) ?
  }

instance showTab :: Show (Tab head tail) where
  show (Tab tab) = "Tab(Columns(" <> "..." <> "), Rows(" <> "..." <> ")"

empty :: Tab _ _
empty = Tab
  { columns : HList.empty
  , rows : Nil
  }
--
-- addColumn :: forall c0 r0 c1 r1 ck. ColType ck => Tab c0 r0 -> Col ck -> Tab c1 r1
-- addColumn (Tab table) column = Tab
--   { columns : HList.cons column table.columns
--   , rows : map (\row -> HList.cons Nothing row) table.rows
--   }
--
-- addRow :: forall c0 cells. Tab c0 cells -> cells -> Tab c0 cells
-- addRow (Tab table) row = Tab
--   { columns : table.columns
--   , rows : (Cons row table.rows)
--   }

module Tab
  ( Cell
  , Col
  , class ColType
  , kindOf
  , Tab
  , addColumn
  -- , addRow
  , empty
  , createColumn
  ) where

import Data.List
import Data.Vec
import Prelude

import Data.Maybe (Maybe(..))
import Data.Typelevel.Bool (True)
import Data.Typelevel.Num (class Nat, class Succ, D0)
import Data.Vec (empty, snoc) as Vec
import HList (HList(..), cons)
import HList as HList
import Partial.Unsafe (unsafePartial)

newtype Col x = Col
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kindOf :: Col a -> String

instance stringCol :: ColType String where
  kindOf c = "String"
instance intCol :: ColType Int where
  kindOf c = "Int"

instance showStringCol :: Show (Col String) where
  show (col@Col c) = "Column(" <> show c.id <> ", " <> c.name <> ", " <> kindOf col <> ")"

createColumn :: forall x. ColType x => x -> Int -> String -> Col x
createColumn colTypeTag id name = Col
  { id : id
  , name : name
  , kind : colTypeTag
  }

-- TODO Removes all rows for now to get it working at all...
addColumn :: forall a b l. Tab a l -> Col b -> Tab b (HList a l)
addColumn (Tab tab) (Col col) = Tab
  { columns: HNil
  , rows: Nil
  }

type Cell a = Maybe a

type Cells l = forall a. HList a l

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab head tail = Tab
  { columns :: HList (Col head) tail
  , rows :: List (HList (Cell head) (Cells tail)) -- something like (ToRowMap head) (ToRowMap tail) ?
  }

instance showTab :: Show (Tab head tail) where
  show (Tab tab) = "Tab(Columns(" <> "..." <> "), Rows(" <> "..." <> ")"

empty :: Tab _ _
empty = Tab
  { columns : HList.empty
  , rows : Nil
  }
--
-- addColumn :: forall c0 r0 c1 r1 ck. ColType ck => Tab c0 r0 -> Col ck -> Tab c1 r1
-- addColumn (Tab table) column = Tab
--   { columns : HList.cons column table.columns
--   , rows : map (\row -> HList.cons Nothing row) table.rows
--   }
--
-- addRow :: forall c0 cells. Tab c0 cells -> cells -> Tab c0 cells
-- addRow (Tab table) row = Tab
--   { columns : table.columns
--   , rows : (Cons row table.rows)
--   }


Start implementing scrolling

Start implementing scrolling

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), BrowserPoint(..), ChrId(..), CoordSys(..), Interval(..), IntervalPoint, LocalPoint(..), Point, canvasToBrowserOffset, canvasToView, frameToChr, globalToFrame, intervalSize, intervalToGlobal, mkCoordSys)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- type View = { lHand :: ChrId, rHand :: ChrId }

-- type ZipperRange a =
--   { left  :: List a
--   , focus :: List a
--   , right :: List a
--   }

-- zipSlideLeft :: forall a.
--                 ZipperRange a
--              -> ZipperRange a
-- zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
--     Nothing, _  -> zr
--     _ , Nothing -> zr
--     Just l, Just f ->
--       let left'  = l.tail
--           focus' = l.head : f.init
--           right' = f.last : right
--       in {left: left', focus: focus', right: right'}

-- zipSlideRight :: forall a.
--                  ZipperRange a
--               -> ZipperRange a
-- zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
--     Nothing, _  -> zr
--     _ , Nothing -> zr
--     Just f, Just r ->
--       let left'  = f.head : left
--           focus' = f.tail <> List.singleton r.head
--           right' = r.tail
--       in {left: left', focus: focus', right: right'}

-- zipZoomIn :: forall a.
--              ZipperRange a
--           -> ZipperRange a
-- zipZoomIn zr@{left, focus, right} = case List.uncons focus of
--   Nothing -> zr
--   Just {head, tail} -> case List.unsnoc tail of
--     Nothing -> zr
--     Just {init, last} ->
--       let left'  = head : left
--           focus' = init
--           right' = last : right
--       in {left: left', focus: focus', right: right'}

-- zipZoomOut :: forall a.
--               ZipperRange a
--            -> ZipperRange a
-- zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
--   Nothing, Nothing -> zr
--   Nothing, Just r ->
--     let focus' = focus <> List.singleton r.head
--         right' = r.tail
--     in zr { focus = focus', right = right' }
--   Just l, Nothing ->
--     let left' = l.tail
--         focus' = l.head : focus
--     in zr { focus = focus', left = left' }
--   Just l, Just r ->
--     let left' = l.tail
--         focus' = l.head : focus <> List.singleton r.head
--         right' = r.tail
--     in { left: left', focus: focus', right: right' }

-- focusArray :: forall a.
--               ZipperRange a
--            -> Array a
-- focusArray {focus} = Array.fromFoldable focus

-- unfocusArray :: forall a.
--                 Array a
--              -> ZipperRange a
-- unfocusArray arr = { left: Nil
--                    , focus: List.fromFoldable arr
--                    , right: Nil
--                    }

-- data UpdateView =
--     GoLeft
--   | GoRight
--   | Out
--   | In
--   | NoOp

-- btnScroll :: Event UpdateView
-- btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
--             const GoRight <$> buttonEvent "scrollRight"

-- btnZoom :: Event UpdateView
-- btnZoom = const Out <$> buttonEvent "zoomOut" <|>
--           const In  <$> buttonEvent "zoomIn"

-- btnUpdateView :: Event UpdateView
-- btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

-- mkFoldView :: UpdateView
--            -> ZipperRange ChrId
--            -> ZipperRange ChrId
-- mkFoldView uv zr = case uv of
--   GoLeft  -> zipSlideLeft zr
--   GoRight -> zipSlideRight zr
--   Out     -> zipZoomOut zr
--   In      -> zipZoomIn zr
--   NoOp    -> zr

-- chrZREvent :: Array ChrId
--            -> Event UpdateView
--            -> Event (ZipperRange ChrId)
-- chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

-- chrsArrayEvent :: Event (ZipperRange ChrId)
--                -> Event (Array ChrId)
-- chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

type BrowserView = Interval BrowserPoint

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -- -> Event (Array ChrId)
             -> Event (BrowserView)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo' s 0.25 box dat
                         in map dd

chrsToView :: CoordSys ChrId BrowserPoint
           -> Array ChrId
           -> Interval BrowserPoint
chrsToView (CoordSys csys) view = fromMaybe (Interval (BPoint zero) (BPoint one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ ivS) <- Array.find ((==) f <<< fst) csys.intervals
  (Tuple _ ivE) <- Array.find ((==) l <<< fst) csys.intervals

  let (Interval start _) = ivS.interval
      (Interval _   end) = ivE.interval

  pure $ Interval start end

viewRange :: CoordSys ChrId BrowserPoint
          -> Event (Array ChrId)
          -> Event (Interval BrowserPoint)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal $ Local iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint -> Event BrowserPoint -> Event (Maybe (Tuple ChrId IntervalPoint))
frameClick csys = map (globalToFrame csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (Tuple ChrId IntervalPoint))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = f <$> ev
  where f x = do
          p@(Tuple i _) <- x
          Tuple i <$> frameToChr csys p

showView :: Interval BrowserPoint -> String
showView (Interval (BPoint l) (BPoint r)) = "< " <> BigInt.toString l <> " -- " <> BigInt.toString r <> " >"

showLP :: IntervalPoint -> String
showLP (Local iv p) = "Interval: " <> showView iv <> ";\t" <> show p

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event (Interval BrowserPoint)
            -> Event Number
            -> Event BrowserPoint
browserDrag w v ev = canvasToBrowserOffset w
                     <$> map intervalSize v
                     <*> ev

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv = canvasDrag canvas

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Interval BrowserPoint)
      viewEv' = viewRange coordSys viewEvent

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe _)
      fClick = frameClick coordSys gClick

      cClick :: Event (Maybe _)
      cClick = chrClick coordSys fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just (Tuple chr i)) = "Frame: " <> show chr <> showLP i
               sF Nothing = "No Frame"
               sChr (Just (Tuple chr bp)) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), BrowserPoint(..), ChrId(..), CoordSys(..), Interval(..), IntervalPoint, LocalPoint(..), Point, canvasToView, frameToChr, globalToFrame, intervalToGlobal, mkCoordSys)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom <|> (const NoOp <$> buttonEvent "redraw")

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat = let dd = drawDemo s 0.25 box dat
                         in map dd

chrsToView :: CoordSys ChrId BrowserPoint
           -> Array ChrId
           -> Interval BrowserPoint
chrsToView (CoordSys csys) view = fromMaybe (Interval (BPoint zero) (BPoint one)) $ do
  f <- Array.head view
  l <- Array.last view
  (Tuple _ ivS) <- Array.find ((==) f <<< fst) csys.intervals
  (Tuple _ ivE) <- Array.find ((==) l <<< fst) csys.intervals

  let (Interval start _) = ivS.interval
      (Interval _   end) = ivE.interval

  pure $ Interval start end

viewRange :: CoordSys ChrId BrowserPoint
          -> Event (Array ChrId)
          -> Event (Interval BrowserPoint)
viewRange chrs = map (chrsToView chrs)

clickEvent :: forall r.
              CanvasElement
           -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r.
             { width :: Pixels | r}
          -> Event Pixels
          -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint)
            -> Event (Ratio BigInt)
            -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal $ Local iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (Tuple ChrId IntervalPoint))
frameClick csys = map (globalToFrame csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (Tuple ChrId IntervalPoint))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = f <$> ev
  where f x = do
          p@(Tuple i _) <- x
          Tuple i <$> frameToChr csys p

showView :: Interval BrowserPoint -> String
showView (Interval (BPoint l) (BPoint r)) = "< " <> BigInt.toString l <> " -- " <> BigInt.toString r <> " >"

showLP :: IntervalPoint -> String
showLP (Local iv p) = "Interval: " <> showView iv <> ";\t" <> show p

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent :: Event (Array ChrId)
      viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

      viewEv' :: Event (Interval BrowserPoint)
      viewEv' = viewRange coordSys viewEvent

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEv' vClick

      fClick :: Event (Maybe _)
      fClick = frameClick coordSys gClick

      cClick :: Event (Maybe _)
      cClick = chrClick coordSys fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEv' <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just (Tuple chr i)) = "Frame: " <> show chr <> showLP i
               sF Nothing = "No Frame"
               sChr (Just (Tuple chr bp)) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, padding: 10.0, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]