Fetch track data over time into three separate AVars

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, Producer, connect, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
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.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap, lmap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, for_, length, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant)
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: 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 :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: 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 :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

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

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

browserLoop :: { tracks     :: Pair BigInt -> List (Array RenderedTrack)
               , relativeUI :: Pair BigInt -> Drawing
               , fixedUI :: Drawing }
            -> Number
            -> BrowserCanvas
            -> { viewState   :: AVar BrowserState
               , viewCmds    :: AVar UpdateView
               , renderFiber :: AVar (Fiber _ _)}
            -> Aff _ _
browserLoop browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      tracks = browser.tracks vState.visible

  liftEff do
    log $ "current scale: " <> show scale <> " bps/pixel"

  renderer <- forkAff $ renderGlyphs vState.visible scale tracks canvases

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay
    Drawing.render trackCtx $ browser.relativeUI vState.visible
    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

  let newState = updateViewFold cmd vState.visible

  putVar { visible: newState } state.viewState

  liftEff $ log $ "new view: " <> show newState

  pure unit

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  {width, height} <- liftEff $ Canvas.getCanvasDimensions canvases.track
  let bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  trackCtx   <- liftEff $ getContext2D canvases.track
  overlayCtx <- liftEff $ getContext2D canvases.overlay

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  liftEff do
    log $ "offset: " <> show offset
    log $ "pixels view: " <> show vw'
    Drawing.render trackCtx bg

  -- Shift canvas so we render to the visible part
  void $ liftEff $ Canvas.translate { translateX: (-offset), translateY: zero } trackCtx

  -- Predicates to filter out glyphs that would not be visible on screen
  let predB p = p.x - 10.0 > pxL
             && p.x + 10.0 < pxR
      predS s = s.width >= one
             && s.point.x - s.width > pxL
             && s.point.x + s.width < pxR

  for_ (List.reverse ts) \segs -> do
    liftEff $ foreachE segs $ case _ of

      Left {drawing, points}  -> do
        let points' = filter predB points
        log $ "rendering " <> show (Array.length points') <> " glyphs, out of " <> show (Array.length points)
        renderBatch canvases.buffer {drawing, points: points'} trackCtx

      Right gs -> do
        let gs' = filter predS gs
        log $ "rendering " <> show (Array.length gs') <> " glyphs, out of " <> show (Array.length gs)
        foreachE gs' \s ->
          Drawing.render trackCtx
            $ Drawing.translate s.point.x s.point.y
            $ s.drawing

  void $ liftEff $ Canvas.translate { translateX: offset, translateY: zero } trackCtx

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

-- browserLoopN :: CoordSys _ _
--              -> BrowserCanvas
--              ->

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 40.0
      legendWidth = 100.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    maybe
      (throwError $ error "Could not find browser element")
      (\el -> liftEff $ createBrowserCanvas el browserDimensions)
      cont

  trackData <- do
    genes <- traverse (getBedGenes cSys) (Just "./mouse.json")
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ browserLoop mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  {-
  prod <- produceBed "./mouse.json"

  res <- makeVar []
  let cnsm = bedConsumer res

  let prcs :: Process (Aff _) Unit
      prcs = prod `connect` cnsm

  liftEff $ log "starting process"

  _ <- forkAff do
    runProcess prcs
    bedData <- readVar res
    liftEff $ log $ "process complete, loaded: " <> show (Array.length bedData) <> " lines"
  -}

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
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.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap, lmap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter, partitioned)
import Data.Foldable (fold, foldMap, for_, length)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe, maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine, produceBed)
import Genetics.Browser.Track.Demo (annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: 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 :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: 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 :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

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

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

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

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

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: { gwas        :: Maybe String
                      , annotations :: Maybe String
                      , genes       :: Maybe String
                      }
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

browserLoop :: { tracks     :: Pair BigInt -> List (Array RenderedTrack)
               , relativeUI :: Pair BigInt -> Drawing
               , fixedUI :: Drawing }
            -> Number
            -> BrowserCanvas
            -> { viewState   :: AVar BrowserState
               , viewCmds    :: AVar UpdateView
               , renderFiber :: AVar (Fiber _ _)}
            -> Aff _ _
browserLoop browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      tracks = browser.tracks vState.visible

  liftEff do
    log $ "current scale: " <> show scale <> " bps/pixel"

  renderer <- forkAff $ renderGlyphs vState.visible scale tracks canvases

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay
    Drawing.render trackCtx $ browser.relativeUI vState.visible
    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

  let newState = updateViewFold cmd vState.visible

  putVar { visible: newState } state.viewState

  liftEff $ log $ "new view: " <> show newState

  pure unit

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  {width, height} <- liftEff $ Canvas.getCanvasDimensions canvases.track
  let bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  trackCtx   <- liftEff $ getContext2D canvases.track
  overlayCtx <- liftEff $ getContext2D canvases.overlay

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  liftEff do
    log $ "offset: " <> show offset
    log $ "pixels view: " <> show vw'
    Drawing.render trackCtx bg

  -- Shift canvas so we render to the visible part
  void $ liftEff $ Canvas.translate { translateX: (-offset), translateY: zero } trackCtx

  -- Predicates to filter out glyphs that would not be visible on screen
  let predB p = p.x - 10.0 > pxL
             && p.x + 10.0 < pxR
      predS s = s.width >= one
             && s.point.x - s.width > pxL
             && s.point.x + s.width < pxR

  for_ (List.reverse ts) \segs -> do
    liftEff $ foreachE segs $ case _ of

      Left {drawing, points}  -> do
        let points' = filter predB points
        log $ "rendering " <> show (Array.length points') <> " glyphs, out of " <> show (Array.length points)
        renderBatch canvases.buffer {drawing, points: points'} trackCtx

      Right gs -> do
        let gs' = filter predS gs
        log $ "rendering " <> show (Array.length gs') <> " glyphs, out of " <> show (Array.length gs)
        foreachE gs' \s ->
          Drawing.render trackCtx
            $ Drawing.translate s.point.x s.point.y
            $ s.drawing

  void $ liftEff $ Canvas.translate { translateX: offset, translateY: zero } trackCtx

bedConsume :: AVar (Array ParsedLine) -> Array ParsedLine -> Aff _ (Maybe Unit)
bedConsume av ls = do
  sofar <- takeVar av
  let new = sofar <> ls
  liftEff $ log $ "received " <> show (Array.length new) <> " lines"
  putVar new av
  pure Nothing

bedConsumer :: AVar (Array ParsedLine) -> Consumer (Array ParsedLine) (Aff _) Unit
bedConsumer av = Co.consumer (bedConsume av)

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 40.0
      legendWidth = 100.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    maybe
      (throwError $ error "Could not find browser element")
      (\el -> liftEff $ createBrowserCanvas el browserDimensions)
      cont

  trackData <- do
    genes <- traverse (getBedGenes cSys) (Just "./mouse.json")
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ browserLoop mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  {-
  prod <- produceBed "./mouse.json"

  res <- makeVar []
  let cnsm = bedConsumer res

  let prcs :: Process (Aff _) Unit
      prcs = prod `connect` cnsm

  liftEff $ log "starting process"

  _ <- forkAff do
    runProcess prcs
    bedData <- readVar res
    liftEff $ log $ "process complete, loaded: " <> show (Array.length bedData) <> " lines"
  -}

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c


Add types to Workspace fns

Add types to Workspace fns

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

import SlamData.Prelude

import Control.Coroutine (Producer, Consumer, runProcess, await, ($$))
import Control.Coroutine.Aff (produce)
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (writeRef)
import Control.UI.Browser as Browser

import Ace.Config as AceConfig

import Data.Map.Diff as Diff
import Data.Nullable (toMaybe)
import Data.StrMap as SM

import DOM.HTML.Document (body)
import DOM.HTML (window)
import DOM.HTML.Types (HTMLElement, htmlElementToElement, htmlElementToNode, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Element (setClassName)
import DOM.Node.Node (removeChild)
import DOM.Node.Types (elementToNode)
import DOM.Node.ParentNode (querySelector)

import Halogen as H
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI, HalogenIO)

import SlamData.Config as Config
import SlamData.Effects (SlamDataEffects)
import SlamData.Monad (runSlam)
import SlamData.Wiring (Wiring(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action (Action(..), toAccessType)
import SlamData.Workspace.Component as Workspace
import SlamData.Workspace.Card.Port.VarMap (URLVarMap)
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse (resolveUrlVarMaps)
import SlamData.Workspace.Routing (Routes(..), routing)
import SlamData.Workspace.StyleLoader as StyleLoader
import SlamData.Quasar.Auth.Permission as Permission

import Routing as Routing

import Utils.Path as UP

type WorkspaceIO = HalogenIO Workspace.Query Void (Aff SlamDataEffects)
data RouterState = RouterState Routes Wiring WorkspaceIO

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.modePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.themePath (Config.baseUrl ⊕ "js/ace")
  HA.runHalogenAff $ forkAff routeSignal
  StyleLoader.loadStyles

routeSignal ∷ Aff SlamDataEffects Unit
routeSignal = do
  runProcess (routeProducer $$ routeConsumer Nothing)

  where
  routeProducer ∷ Producer Routes (Aff SlamDataEffects) Unit
  routeProducer = produce \emit →
    Routing.matches' UP.decodeURIPath routing \_ → emit ∘ Left

  routeConsumer ∷ Maybe RouterState → Consumer Routes (Aff SlamDataEffects) Unit
  routeConsumer state  = do
    new ← await
    case new, state of
      -- Initialize the Workspace component
      WorkspaceRoute path deckId action varMaps, Nothing → do
        permissionTokenHashes ← lift $ liftEff Permission.retrieveTokenHashes
        wiring ← lift $ Wiring.make path (toAccessType action) varMaps permissionTokenHashes
        mount wiring new

      -- Reload the page on path change or varMap change
      WorkspaceRoute path _ action _, Just (RouterState (WorkspaceRoute path' _ action' _) wiring _)
        | path ≠ path' || toAccessType action ≠ toAccessType action' →
        reload wiring new

      -- Transition Workspace
      WorkspaceRoute path deckId action varMaps, Just (RouterState old wiring driver) →
        case old of
          WorkspaceRoute _ deckId' _ varMaps'
            | deckId ≡ deckId' ∧ varMaps ≡ varMaps' →
                routeConsumer (Just (RouterState new wiring driver))
          WorkspaceRoute _ deckId' _ varMaps' → do
            when (varMaps ≠ varMaps') $ lift do
              liftEff $ writeRef (Wiring.unWiring wiring).varMaps varMaps
              diffVarMaps wiring varMaps' varMaps
            lift $ setup new driver
            routeConsumer (Just (RouterState new wiring driver))

  diffVarMaps
    ∷ Wiring
    → SM.StrMap URLVarMap
    → SM.StrMap URLVarMap
    → Aff SlamDataEffects Unit
  diffVarMaps (Wiring wiring) vm1 vm2 = do
    decks ← Cache.snapshot wiring.eval.decks
    cards ← Cache.snapshot wiring.eval.cards
    let
      vm1' = resolveUrlVarMaps decks cards vm1
      vm2' = resolveUrlVarMaps decks cards vm2
    runSlam (Wiring wiring)
      $ traverse_ (P.queueEvalImmediate ∘ Card.toAll)
      $ Diff.updated
      $ Diff.diff vm1' vm2'

  reload ∷ Wiring → Routes → Consumer Routes (Aff SlamDataEffects) Unit
  reload (Wiring wiring) new@(WorkspaceRoute path _ action varMaps) = do
    wiring' ←
      if path ≡ wiring.path
        then pure $ Wiring wiring { path = path, accessType = toAccessType action }
        else lift $ Wiring.make path (toAccessType action) varMaps wiring.auth.permissionTokenHashes
    lift $ removeFromBody ".sd-workspace"
    mount wiring' new

  mount ∷ Wiring → Routes → Consumer Routes (Aff SlamDataEffects) Unit
  mount wiring new@(WorkspaceRoute _ _ action _) = do
    let ui = H.hoist (runSlam wiring) $ Workspace.component (toAccessType action)
    driver ← lift $ runUI ui unit =<< awaitBody'
    lift $ setup new driver
    routeConsumer (Just (RouterState new wiring driver))

  setup ∷ Routes → WorkspaceIO → Aff SlamDataEffects Unit
  setup new@(WorkspaceRoute _ deckId action varMaps) driver = do
    when (toAccessType action ≡ AT.ReadOnly) do
      isEmbedded ←
        liftEff $ Browser.detectEmbedding
      let
        bodyClass =
          if isEmbedded
            then "sd-workspace-page sd-embedded"
            else "sd-workspace-page"
      void
        $ liftEff
        $ traverse (setClassName bodyClass ∘ htmlElementToElement)
        ∘ toMaybe
        =<< body
        =<< document
        =<< window

    void $ forkAff case action of
      Load _ → driver.query $ H.action $ Workspace.Load deckId
      New → driver.query $ H.action Workspace.New
      Exploring fp → driver.query $ H.action $ Workspace.ExploreFile fp

awaitBody' ∷ Aff SlamDataEffects HTMLElement
awaitBody' = do
  body ← liftEff $ map toMaybe $ window >>= document >>= body
  maybe HA.awaitBody pure body

removeFromBody ∷ String → Aff SlamDataEffects Unit
removeFromBody sel = liftEff $ void $ runMaybeT do
  body ← MaybeT $ map toMaybe $ window >>= document >>= body
  root ← MaybeT $ map toMaybe $ window >>= document >>= htmlDocumentToParentNode >>> querySelector sel
  lift $ removeChild (elementToNode root) (htmlElementToNode body)

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

import SlamData.Prelude

import Control.Coroutine (runProcess, await, ($$))
import Control.Coroutine.Aff (produce)
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (writeRef)
import Control.UI.Browser as Browser

import Ace.Config as AceConfig

import Data.Map.Diff as Diff
import Data.Nullable (toMaybe)

import DOM.HTML.Document (body)
import DOM.HTML (window)
import DOM.HTML.Types (HTMLElement, htmlElementToElement, htmlElementToNode, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Element (setClassName)
import DOM.Node.Node (removeChild)
import DOM.Node.Types (elementToNode)
import DOM.Node.ParentNode (querySelector)

import Halogen as H
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI, HalogenIO)

import SlamData.Config as Config
import SlamData.Effects (SlamDataEffects)
import SlamData.Monad (runSlam)
import SlamData.Wiring (Wiring(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action (Action(..), toAccessType)
import SlamData.Workspace.Component as Workspace
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse (resolveUrlVarMaps)
import SlamData.Workspace.Routing (Routes(..), routing)
import SlamData.Workspace.StyleLoader as StyleLoader
import SlamData.Quasar.Auth.Permission as Permission

import Routing as Routing

import Utils.Path as UP

type WorkspaceIO = HalogenIO Workspace.Query Void (Aff SlamDataEffects)
data RouterState = RouterState Routes Wiring WorkspaceIO

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.modePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.themePath (Config.baseUrl ⊕ "js/ace")
  HA.runHalogenAff $ forkAff routeSignal
  StyleLoader.loadStyles

routeSignal ∷ Aff SlamDataEffects Unit
routeSignal = do
  runProcess (routeProducer $$ routeConsumer Nothing)

  where
  routeProducer = produce \emit →
    Routing.matches' UP.decodeURIPath routing \_ → emit ∘ Left

  routeConsumer state  = do
    new ← await
    case new, state of
      -- Initialize the Workspace component
      WorkspaceRoute path deckId action varMaps, Nothing → do
        permissionTokenHashes ← lift $ liftEff Permission.retrieveTokenHashes
        wiring ← lift $ Wiring.make path (toAccessType action) varMaps permissionTokenHashes
        mount wiring new

      -- Reload the page on path change or varMap change
      WorkspaceRoute path _ action _, Just (RouterState (WorkspaceRoute path' _ action' _) wiring _)
        | path ≠ path' || toAccessType action ≠ toAccessType action' →
        reload wiring new

      -- Transition Workspace
      WorkspaceRoute path deckId action varMaps, Just (RouterState old wiring driver) →
        case old of
          WorkspaceRoute _ deckId' _ varMaps'
            | deckId ≡ deckId' ∧ varMaps ≡ varMaps' →
                routeConsumer (Just (RouterState new wiring driver))
          WorkspaceRoute _ deckId' _ varMaps' → do
            when (varMaps ≠ varMaps') $ lift do
              liftEff $ writeRef (Wiring.unWiring wiring).varMaps varMaps
              diffVarMaps wiring varMaps' varMaps
            lift $ setup new driver
            routeConsumer (Just (RouterState new wiring driver))

  diffVarMaps (Wiring wiring) vm1 vm2 = do
    decks ← Cache.snapshot wiring.eval.decks
    cards ← Cache.snapshot wiring.eval.cards
    let
      vm1' = resolveUrlVarMaps decks cards vm1
      vm2' = resolveUrlVarMaps decks cards vm2
    runSlam (Wiring wiring)
      $ traverse_ (P.queueEvalImmediate ∘ Card.toAll)
      $ Diff.updated
      $ Diff.diff vm1' vm2'

  reload (Wiring wiring) new@(WorkspaceRoute path _ action varMaps) = do
    wiring' ←
      if path ≡ wiring.path
        then pure $ Wiring wiring { path = path, accessType = toAccessType action }
        else lift $ Wiring.make path (toAccessType action) varMaps wiring.auth.permissionTokenHashes
    lift $ removeFromBody ".sd-workspace"
    mount wiring' new

  mount wiring new@(WorkspaceRoute _ _ action _) = do
    let ui = H.hoist (runSlam wiring) $ Workspace.component (toAccessType action)
    driver ← lift $ runUI ui unit =<< awaitBody'
    lift $ setup new driver
    routeConsumer (Just (RouterState new wiring driver))

  setup new@(WorkspaceRoute _ deckId action varMaps) driver = do
    when (toAccessType action ≡ AT.ReadOnly) do
      isEmbedded ←
        liftEff $ Browser.detectEmbedding
      let
        bodyClass =
          if isEmbedded
            then "sd-workspace-page sd-embedded"
            else "sd-workspace-page"
      void
        $ liftEff
        $ traverse (setClassName bodyClass ∘ htmlElementToElement)
        ∘ toMaybe
        =<< body
        =<< document
        =<< window

    forkAff case action of
      Load _ → driver.query $ H.action $ Workspace.Load deckId
      New → driver.query $ H.action Workspace.New
      Exploring fp → driver.query $ H.action $ Workspace.ExploreFile fp

awaitBody' ∷ Aff SlamDataEffects HTMLElement
awaitBody' = do
  body ← liftEff $ map toMaybe $ window >>= document >>= body
  maybe HA.awaitBody pure body

removeFromBody ∷ String → Aff SlamDataEffects Unit
removeFromBody sel = liftEff $ void $ runMaybeT do
  body ← MaybeT $ map toMaybe $ window >>= document >>= body
  root ← MaybeT $ map toMaybe $ window >>= document >>= htmlDocumentToParentNode >>> querySelector sel
  lift $ removeChild (elementToNode root) (htmlElementToNode body)


Fix substInParent behavior (#384)

Fix substInParent behavior (#384)

module Halogen.VDom.Driver
  ( runUI
  , module Halogen.Aff.Driver
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)

import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..))
import Data.Nullable (toMaybe)

import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (HTMLElement, htmlElementToNode, htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Node (appendChild, removeChild, parentNode, nextSibling, insertBefore) as DOM
import DOM.Node.Types (Document, Element, Node) as DOM

import Halogen.Aff.Driver (HalogenIO)
import Halogen.Aff.Driver as AD
import Halogen.Aff.Driver.State (RenderStateX, unRenderStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Component (Component, ComponentSlot)
import Halogen.HTML.Core (HTML(..), Prop)
import Halogen.Query.InputF (InputF)
import Halogen.VDom as V
import Halogen.VDom.DOM.Prop as VP

type VHTML f g p eff =
  V.VDom (Array (Prop (InputF Unit (f Unit)))) (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))

newtype RenderState s f g p o eff =
  RenderState
    { node :: DOM.Node
    , machine :: V.Step (Eff (HalogenEffects eff)) (VHTML f g p eff) DOM.Node
    }

mkSpec
  :: forall f g p eff
   . (InputF Unit (f Unit) -> Eff (HalogenEffects eff) Unit)
  -> (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit) -> Eff (HalogenEffects eff) (RenderStateX RenderState eff))
  -> DOM.Document
  -> V.VDomSpec
      (HalogenEffects eff)
      (Array (VP.Prop (InputF Unit (f Unit))))
      (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
mkSpec handler renderChild document =
  V.VDomSpec { buildWidget, buildAttributes, document }
  where

  buildAttributes
    :: DOM.Element
    -> V.VDomMachine (HalogenEffects eff) (Array (VP.Prop (InputF Unit (f Unit)))) Unit
  buildAttributes = VP.buildProp handler

  buildWidget
    :: V.VDomSpec (HalogenEffects eff)
          (Array (VP.Prop (InputF Unit (f Unit))))
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
    -> V.VDomMachine (HalogenEffects eff)
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
          DOM.Node
  buildWidget spec slot = do
    rsx <- renderChild slot
    let node = unRenderStateX (\(RenderState { node }) -> node) rsx
    pure (V.Step node patch done)

  patch
    :: V.VDomMachine (HalogenEffects eff)
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
          DOM.Node
  patch slot = do
    rsx <- renderChild slot
    let node = unRenderStateX (\(RenderState { node }) -> node) rsx
    pure (V.Step node patch done)

  done :: Eff (HalogenEffects eff) Unit
  done = pure unit

runUI
  :: forall f eff i o
   . Component HTML f i o (Aff (HalogenEffects eff))
  -> i
  -> DOM.HTMLElement
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI component i element = do
  document <- liftEff $ DOM.htmlDocumentToDocument <$> (DOM.document =<< DOM.window)
  AD.runUI (renderSpec document element) component i

renderSpec
  :: forall eff
   . DOM.Document
  -> DOM.HTMLElement
  -> AD.RenderSpec HTML RenderState eff
renderSpec document container = { render, renderChild: id, removeChild }
  where

  render
    :: forall s f g p o
     . (forall x. InputF x (f x) -> Eff (HalogenEffects eff) Unit)
    -> (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit) -> Eff (HalogenEffects eff) (RenderStateX RenderState eff))
    -> HTML (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
    -> Maybe (RenderState s f g p o eff)
    -> Eff (HalogenEffects eff) (RenderState s f g p o eff)
  render handler child (HTML vdom) =
    case _ of
      Nothing -> do
        let spec = mkSpec handler child document
        machine <- V.buildVDom spec vdom
        let node = V.extract machine
        DOM.appendChild node (DOM.htmlElementToNode container)
        pure $ RenderState { machine, node }
      Just (RenderState { machine, node }) -> do
        parent <- DOM.parentNode node
        nextSib <- DOM.nextSibling node
        machine' <- V.step machine vdom
        let newNode = V.extract machine'
        when (not nodeRefEq node newNode) do
          substInParent newNode (toMaybe nextSib) (toMaybe parent)
        pure $ RenderState { machine: machine', node: newNode }

removeChild
  :: forall eff o p g f s. RenderState s f g p o eff
  -> Eff (HalogenEffects eff) Unit
removeChild (RenderState { node }) = do
  npn <- DOM.parentNode node
  traverse_ (\pn -> DOM.removeChild node pn) (toMaybe npn)

substInParent
  :: forall eff
   . DOM.Node
  -> Maybe DOM.Node
  -> Maybe DOM.Node
  -> Eff (dom :: DOM | eff) Unit
substInParent newNode (Just sib) (Just pn) = void $ DOM.insertBefore newNode sib pn
substInParent newNode Nothing (Just pn) = void $ DOM.appendChild newNode pn
substInParent _ _ _ = pure unit

foreign import nodeRefEq :: DOM.Node -> DOM.Node -> Boolean

module Halogen.VDom.Driver
  ( runUI
  , module Halogen.Aff.Driver
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)

import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..))
import Data.Nullable (toMaybe)

import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (HTMLElement, htmlElementToNode, htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Node (appendChild, removeChild, parentNode, replaceChild) as DOM
import DOM.Node.Types (Document, Element, Node) as DOM

import Halogen.Aff.Driver (HalogenIO)
import Halogen.Aff.Driver as AD
import Halogen.Aff.Driver.State (RenderStateX, unRenderStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Component (Component, ComponentSlot)
import Halogen.HTML.Core (HTML(..), Prop)
import Halogen.Query.InputF (InputF)
import Halogen.VDom as V
import Halogen.VDom.DOM.Prop as VP

type VHTML f g p eff =
  V.VDom (Array (Prop (InputF Unit (f Unit)))) (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))

newtype RenderState s f g p o eff =
  RenderState
    { node :: DOM.Node
    , machine :: V.Step (Eff (HalogenEffects eff)) (VHTML f g p eff) DOM.Node
    }

mkSpec
  :: forall f g p eff
   . (InputF Unit (f Unit) -> Eff (HalogenEffects eff) Unit)
  -> (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit) -> Eff (HalogenEffects eff) (RenderStateX RenderState eff))
  -> DOM.Document
  -> V.VDomSpec
      (HalogenEffects eff)
      (Array (VP.Prop (InputF Unit (f Unit))))
      (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
mkSpec handler renderChild document =
  V.VDomSpec { buildWidget, buildAttributes, document }
  where

  buildAttributes
    :: DOM.Element
    -> V.VDomMachine (HalogenEffects eff) (Array (VP.Prop (InputF Unit (f Unit)))) Unit
  buildAttributes = VP.buildProp handler

  buildWidget
    :: V.VDomSpec (HalogenEffects eff)
          (Array (VP.Prop (InputF Unit (f Unit))))
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
    -> V.VDomMachine (HalogenEffects eff)
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
          DOM.Node
  buildWidget spec slot = do
    rsx <- renderChild slot
    let node = unRenderStateX (\(RenderState { node }) -> node) rsx
    pure (V.Step node patch done)

  patch
    :: V.VDomMachine (HalogenEffects eff)
          (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit))
          DOM.Node
  patch slot = do
    rsx <- renderChild slot
    let node = unRenderStateX (\(RenderState { node }) -> node) rsx
    pure (V.Step node patch done)

  done :: Eff (HalogenEffects eff) Unit
  done = pure unit

runUI
  :: forall f eff i o
   . Component HTML f i o (Aff (HalogenEffects eff))
  -> i
  -> DOM.HTMLElement
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI component i element = do
  document <- liftEff $ DOM.htmlDocumentToDocument <$> (DOM.document =<< DOM.window)
  AD.runUI (renderSpec document element) component i

renderSpec
  :: forall eff
   . DOM.Document
  -> DOM.HTMLElement
  -> AD.RenderSpec HTML RenderState eff
renderSpec document container = { render, renderChild: id, removeChild }
  where

  render
    :: forall s f g p o
     . (forall x. InputF x (f x) -> Eff (HalogenEffects eff) Unit)
    -> (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit) -> Eff (HalogenEffects eff) (RenderStateX RenderState eff))
    -> HTML (ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
    -> Maybe (RenderState s f g p o eff)
    -> Eff (HalogenEffects eff) (RenderState s f g p o eff)
  render handler child (HTML vdom) =
    case _ of
      Nothing -> do
        let spec = mkSpec handler child document
        machine <- V.buildVDom spec vdom
        let node = V.extract machine
        DOM.appendChild node (DOM.htmlElementToNode container)
        pure $ RenderState { machine, node }
      Just (RenderState { machine, node }) -> do
        machine' <- V.step machine vdom
        let newNode = V.extract machine'
        when (not nodeRefEq node newNode) (substInParent node newNode)
        pure $ RenderState { machine: machine', node: newNode }

removeChild
  :: forall eff o p g f s. RenderState s f g p o eff
  -> Eff (HalogenEffects eff) Unit
removeChild (RenderState { node }) = do
  npn <- DOM.parentNode node
  traverse_ (\pn -> DOM.removeChild node pn) (toMaybe npn)

substInParent :: forall eff. DOM.Node -> DOM.Node -> Eff (dom :: DOM | eff) Unit
substInParent oldNode newNode = do
  npn <- DOM.parentNode oldNode
  traverse_ (\pn -> DOM.replaceChild newNode oldNode pn) (toMaybe npn)

foreign import nodeRefEq :: DOM.Node -> DOM.Node -> Boolean