Threaded rendering for a little better performance

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, finally, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, 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)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter)
import Data.Foldable (class Foldable, foldMap, for_, 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(Just, Nothing), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (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.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

-- set an event to fire on the given button id

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

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 }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  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 }

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

  vState <- takeVar state.viewState

  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      (Pair l _ ) = vState.visible
      offset = BigInt.toNumber l / scale
      tracks = browser.tracks vState.visible

  -- fork a new renderFiber
  renderFiber <- forkAff $ renderGlyphs vState.visible scale tracks canvases
  putVar renderFiber state.renderFiber

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

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~
    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      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

      -- update view using received cmd, limiting view to coordsys
  let (Pair l' r') = updateViewFold cmd vState.visible
      newState =
        Pair (max zero l')
             (min (max r'  -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                      (l' + BigInt.fromInt 400))
                  (cSys^._TotalSize))

  putVar { visible: newState } state.viewState

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

  -- Blank out the track canvas and get its context
  trackCtx <- liftEff do
    {width, height} <- Canvas.getCanvasDimensions canvases.track
    trackCtx <- getContext2D canvases.track
    Drawing.render trackCtx
      $ filled (fillColor white) $ rectangle 0.0 0.0 width height
    pure trackCtx

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

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
      pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      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'

      shiftView x =
        void $ liftEff $ Canvas.translate { translateX: x, translateY: zero } trackCtx

  -- Shift canvas so we render to the visible part
  shiftView (-offset)

  -- Make sure we unshift even if renderer is killed
  finally (shiftView offset) do

    for_ ts \track -> do

      for_ track \t -> do
        case t of
          Left {drawing, points}  -> do
            let points' = filter predB points
            liftEff $
              renderBatch canvases.buffer {drawing, points: points'} trackCtx

          Right gs -> do
            let gs' = filter predS gs
            liftEff $ foreachE gs' \s ->
              Drawing.render trackCtx
                $ Drawing.translate s.point.x s.point.y
                $ s.drawing

        -- delay to give the UI thread a moment
        delay (wrap 3.0)

-- 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 }

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

  {width} <- liftEff $ getScreenSize

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

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

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    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 $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  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, 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

-- set an event to fire on the given button id

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

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 }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  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 }

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewState   :: AVar BrowserState
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ _)}
           -> Aff _ _
renderLoop cSys 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
      (Pair l _ ) = vState.visible
      offset = BigInt.toNumber l / scale
      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

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~

    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      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

      -- update view using received cmd, limiting view to coordsys
  let (Pair l' r') = updateViewFold cmd vState.visible
      newState =
        Pair (max zero l')
             (min (max r'  -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                      (l' + BigInt.fromInt 400))
                  (cSys^._TotalSize))

  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
     -- Hack to render more of the canvas just to be sure
  let pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      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 }

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

  {width} <- liftEff $ getScreenSize

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

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

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    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 $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  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


Functor and Applicative instances for StateT

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Trans
import Data.Tuple

data StateT s m a = StateT (s -> m (Tuple a s))

runStateT :: forall s m a. StateT s m a -> s -> m (Tuple a s)
runStateT (StateT s) = s

evalStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m a
evalStateT m s = runStateT m s >>= \(Tuple x _) -> return x

execStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m s
execStateT m s = runStateT m s >>= \(Tuple _ s) -> return s

mapStateT :: forall s m1 m2 a b. (m1 (Tuple a s) -> m2 (Tuple b s)) -> StateT s m1 a -> StateT s m2 b
mapStateT f m = StateT $ f <<< runStateT m

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f

instance functorStateT :: (Monad m) => Functor (StateT s m) where
  (<$>) = liftM1

instance applicativeStateT :: (Monad m) => Applicative (StateT s m) where
  pure = return
  (<*>) = ap

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return $ Tuple a s
  (>>=) (StateT x) f = StateT \s -> do
    Tuple v s' <- x s
    runStateT (f v) s'

instance altStateT :: (Alternative m) => Alternative (StateT s m) where
  empty = StateT $ \_ -> empty
  (<|>) x y = StateT $ \s -> runStateT x s <|> runStateT y s

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return $ Tuple x s

liftCatchState :: forall s m e a. (m (Tuple a s) -> (e -> m (Tuple a s)) -> m (Tuple a s)) -> StateT s m a -> (e -> StateT s m a) -> StateT s m a
liftCatchState catch m h = StateT $ \s -> catch (runStateT m s) (\e -> runStateT (h e) s)

liftListenState :: forall s m a w. (Monad m) => (m (Tuple a s) -> m (Tuple (Tuple a s) w)) -> StateT s m a -> StateT s m (Tuple a w)
liftListenState listen m = StateT $ \s -> do
    Tuple (Tuple a s') w <- listen (runStateT m s)
    return $ Tuple (Tuple a w) s'

liftPassState :: forall s m a b w. (Monad m) => (m (Tuple (Tuple a s) b) -> m (Tuple a s)) -> StateT s m (Tuple a b) -> StateT s m a
liftPassState pass m = StateT $ \s -> pass $ do
    Tuple (Tuple a f) s' <- runStateT m s
    return $ Tuple (Tuple a s') f

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Trans
import Data.Tuple

data StateT s m a = StateT (s -> m (Tuple a s))

runStateT :: forall s m a. StateT s m a -> s -> m (Tuple a s)
runStateT (StateT s) = s

evalStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m a
evalStateT m s = runStateT m s >>= \(Tuple x _) -> return x

execStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m s
execStateT m s = runStateT m s >>= \(Tuple _ s) -> return s

mapStateT :: forall s m1 m2 a b. (m1 (Tuple a s) -> m2 (Tuple b s)) -> StateT s m1 a -> StateT s m2 b
mapStateT f m = StateT $ f <<< runStateT m

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return $ Tuple a s
  (>>=) (StateT x) f = StateT \s -> do
    Tuple v s' <- x s
    runStateT (f v) s'

instance altStateT :: (Alternative m) => Alternative (StateT s m) where
  empty = StateT $ \_ -> empty
  (<|>) x y = StateT $ \s -> runStateT x s <|> runStateT y s

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return $ Tuple x s

liftCatchState :: forall s m e a. (m (Tuple a s) -> (e -> m (Tuple a s)) -> m (Tuple a s)) -> StateT s m a -> (e -> StateT s m a) -> StateT s m a
liftCatchState catch m h = StateT $ \s -> catch (runStateT m s) (\e -> runStateT (h e) s)

liftListenState :: forall s m a w. (Monad m) => (m (Tuple a s) -> m (Tuple (Tuple a s) w)) -> StateT s m a -> StateT s m (Tuple a w)
liftListenState listen m = StateT $ \s -> do
    Tuple (Tuple a s') w <- listen (runStateT m s)
    return $ Tuple (Tuple a w) s'

liftPassState :: forall s m a b w. (Monad m) => (m (Tuple (Tuple a s) b) -> m (Tuple a s)) -> StateT s m (Tuple a b) -> StateT s m a
liftPassState pass m = StateT $ \s -> pass $ do
    Tuple (Tuple a f) s' <- runStateT m s
    return $ Tuple (Tuple a s') f


TODO: api_mst_mission

TODO: api_mst_mission

module KanColle.Expedition.Cost
  ( Cost(..)
  , calcCost
  , getExpeditionCost
  ) where

-- this module serves as a database about expedition's cost
-- TODO: api_mst_mission contains related info that can be extracted.

import Prelude
import Data.Int

-- | Expedition cost. `fuel` and `ammo` are floating numbers
-- | (valid values are taken from `0.0` to `1.0`) representing
-- | percentage of fuel / ammo running an expedition would cost.
-- | And `time` records the total time (in minutes) of running this expedition.
type Cost =
  { fuel :: Number
  , ammo :: Number
  , time :: Int -- | in minutes
  }

noCost :: Cost
noCost = { fuel: 0.0, ammo: 0.0, time: 0 }

-- TODO: need document, or it looks confusing
-- TODO: integrate other parts to use this function
calcCost :: Cost
         -> { fuel :: Int, ammo :: Int }
         -> { fuel :: Int, ammo :: Int }
calcCost c x = { fuel: floor (toNumber x.fuel * c.fuel)
               , ammo: floor (toNumber x.ammo * c.ammo) }

-- | input a valid expedition id and get expedition cost.
getExpeditionCost :: Int -> Cost
getExpeditionCost eId = case eId of
    1 ->  c 3 0   15
    2 ->  c 5 0   30
    3 ->  c 3 2   20
    4 ->  c 5 0   50
    5 ->  c 5 0 $ hm 1 30
    6 ->  c 3 2   40
    7 ->  c 5 0 $ hr 1
    8 ->  c 5 2 $ hr 3

    9 ->  c 5 0 $ hr 4
    10 -> c 3 0 $ hm 1 30
    11 -> c 5 0 $ hr 5
    12 -> c 5 0 $ hr 8
    13 -> c 5 4 $ hr 4
    14 -> c 5 0 $ hr 6
    15 -> c 5 4 $ hr 12
    16 -> c 5 4 $ hr 15

    17 -> c 3 4 $ 45
    18 -> c 5 2 $ hr 5
    19 -> c 5 4 $ hr 6
    20 -> c 5 4 $ hr 2
    21 -> c 8 7 $ hm 2 20
    22 -> c 8 7 $ hr 3
    23 -> c 8 8 $ hr 4
    24 -> c 9 6 $ hm 8 20

    25 -> c 5 8 $ hr 40
    26 -> c 8 8 $ hr 80
    27 -> c 8 8 $ hr 20
    28 -> c 8 8 $ hr 25
    29 -> c 9 4 $ hr 24
    30 -> c 9 7 $ hr 48
    31 -> c 5 0 $ hr 2
    32 -> c 9 3 $ hr 24

    33 -> c 5 8   15
    34 -> c 5 8   30
    35 -> c 8 8 $ hr 7
    36 -> c 8 8 $ hr 9
    37 -> c 8 8 $ hm 2 45
    38 -> c 8 8 $ hm 2 55
    39 -> c 9 9 $ hr 30
    40 -> c 8 7 $ hm 6 50
    _ -> noCost
  where
    hr = (_ * 60)
    hm h m = h*60 + m
    c f a t = { fuel: percent f, ammo: percent a, time: t }
    percent v = toNumber (v * 10) / 100.0

module KanColle.Expedition.Cost
  ( Cost(..)
  , calcCost
  , getExpeditionCost
  ) where

-- this module serves as a database about expedition's cost

import Prelude
import Data.Int

-- | Expedition cost. `fuel` and `ammo` are floating numbers
-- | (valid values are taken from `0.0` to `1.0`) representing
-- | percentage of fuel / ammo running an expedition would cost.
-- | And `time` records the total time (in minutes) of running this expedition.
type Cost =
  { fuel :: Number
  , ammo :: Number
  , time :: Int -- | in minutes
  }

noCost :: Cost
noCost = { fuel: 0.0, ammo: 0.0, time: 0 }

-- TODO: need document, or it looks confusing
-- TODO: integrate other parts to use this function
calcCost :: Cost
         -> { fuel :: Int, ammo :: Int }
         -> { fuel :: Int, ammo :: Int }
calcCost c x = { fuel: floor (toNumber x.fuel * c.fuel)
               , ammo: floor (toNumber x.ammo * c.ammo) }

-- | input a valid expedition id and get expedition cost.
getExpeditionCost :: Int -> Cost
getExpeditionCost eId = case eId of
    1 ->  c 3 0   15
    2 ->  c 5 0   30
    3 ->  c 3 2   20
    4 ->  c 5 0   50
    5 ->  c 5 0 $ hm 1 30
    6 ->  c 3 2   40
    7 ->  c 5 0 $ hr 1
    8 ->  c 5 2 $ hr 3

    9 ->  c 5 0 $ hr 4
    10 -> c 3 0 $ hm 1 30
    11 -> c 5 0 $ hr 5
    12 -> c 5 0 $ hr 8
    13 -> c 5 4 $ hr 4
    14 -> c 5 0 $ hr 6
    15 -> c 5 4 $ hr 12
    16 -> c 5 4 $ hr 15

    17 -> c 3 4 $ 45
    18 -> c 5 2 $ hr 5
    19 -> c 5 4 $ hr 6
    20 -> c 5 4 $ hr 2
    21 -> c 8 7 $ hm 2 20
    22 -> c 8 7 $ hr 3
    23 -> c 8 8 $ hr 4
    24 -> c 9 6 $ hm 8 20

    25 -> c 5 8 $ hr 40
    26 -> c 8 8 $ hr 80
    27 -> c 8 8 $ hr 20
    28 -> c 8 8 $ hr 25
    29 -> c 9 4 $ hr 24
    30 -> c 9 7 $ hr 48
    31 -> c 5 0 $ hr 2
    32 -> c 9 3 $ hr 24

    33 -> c 5 8   15
    34 -> c 5 8   30
    35 -> c 8 8 $ hr 7
    36 -> c 8 8 $ hr 9
    37 -> c 8 8 $ hm 2 45
    38 -> c 8 8 $ hm 2 55
    39 -> c 9 9 $ hr 30
    40 -> c 8 7 $ hm 6 50
    _ -> noCost
  where
    hr = (_ * 60)
    hm h m = h*60 + m
    c f a t = { fuel: percent f, ammo: percent a, time: t }
    percent v = toNumber (v * 10) / 100.0


Clean up Handlers.purs

Clean up Handlers.purs

module Genetics.Browser.Events.Handler
       ( TrackSink
       , emptyTrackSink
       , appendTrackSink
       , applyTrackSink
       , forkTrackSink
       , TrackSource
       , emptyTrackSource
       , appendTrackSource
       , applyTrackSource
       ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Data.List (List, mapMaybe, singleton, (:))
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.Record (insert)
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, expand, inj)
import Type.Row (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- | TrackSink is basically a record of functions which can handle some
-- | input in the form of Variants.
-- | `rin` is the row of types that this can handle,
-- | `rfun` is the row of types that corresponds to the record with functions
-- | `out` is the output type; all functions in `rfun` must have `out` as output
data TrackSink (rIn :: # Type) (rFun :: # Type) output = TrackSink (Record rFun)

emptyTrackSink :: ∀ b.
               TrackSink () () b
emptyTrackSink = TrackSink {}

mkTrackSink :: ∀ l a b rIn rFun.
               RowLacks l ()
            => RowCons l (a -> b) () rFun
            => RowCons l a () rIn
            => IsSymbol l
            => SProxy l
            -> (a -> b)
            -> TrackSink rIn rFun b
mkTrackSink l f = TrackSink $ insert l f {}

-- | Given a label and function, adds a handler to an existing TrackSink.
-- | The label must not already be handled by the TrackSink.
appendTrackSink :: ∀ l a b rIn1 rIn2 rFun1 rFun2.
                   RowLacks l rIn1
                => RowLacks l rFun1
                => RowCons l (a -> b) rFun1 rFun2
                => RowCons l a rIn1 rIn2
                => IsSymbol l
                => SProxy l
                -> (a -> b)
                -> TrackSink rIn1 rFun1 b
                -> TrackSink rIn2 rFun2 b
appendTrackSink l f (TrackSink r) = TrackSink $ insert l f r

-- | Runs a handler on an input, where the input is a Variant whose row is a subset of the
-- | TrackSink input row.
applyTrackSink :: ∀ lt a b rIn rFun.
                  Union lt a rIn
               => TrackSink rIn rFun b
               -> Variant lt
               -> b
applyTrackSink (TrackSink h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

-- | Forks an Aff process with a Handler that performs effects, using some environment.
-- | For example, `env` could be a Biodalliance instance.
forkTrackSink :: ∀ lt a rIn rFun eff env.
                 Union lt a rIn
              => TrackSink rIn rFun (env -> Eff (avar :: AVAR | eff) Unit)
              -> env
              -> BusRW (Variant lt)
              -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkTrackSink h env bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyTrackSink h val $ env

-- | An TrackSource has a list of parsers for some input, and can be used to
-- | produce heterogenous lists of parsed values
-- | `in` is the input type; the type of data that this handler can parse
-- | `rout` is the row of types that this can produce
data TrackSource input (rOut :: # Type) = TrackSource (List (input -> Maybe (Variant rOut)))

emptyTrackSource :: ∀ a.
                    TrackSource a ()
emptyTrackSource = TrackSource mempty

mkTrackSource :: ∀ l a b rOut.
                 RowCons l b () rOut
              => IsSymbol l
              => SProxy l
              -> (a -> Maybe b)
              -> TrackSource a rOut
mkTrackSource l f = TrackSource $ singleton f'
  where f' :: a -> Maybe (Variant rOut)
        f' a = inj l <$> f a

-- | Given a label and parser, adds a handler to an existing TrackSource.
-- | The label must not already be produced by the TrackSource.
appendTrackSource :: ∀ l a b rOut1 r rOut2.
                     Union rOut1 r rOut2
                  => RowLacks l rOut1
                  => RowCons l b rOut1 rOut2
                  => IsSymbol l
                  => SProxy l
                  -> (a -> Maybe b)
                  -> TrackSource a rOut1
                  -> TrackSource a rOut2
appendTrackSource l f (TrackSource h) = TrackSource $ f' : (map <<< map <<< map) expand h
  where f' :: a -> Maybe (Variant rOut2)
        f' a = inj l <$> f a

-- | Runs an TrackSource, producing a list of all successful parses of the input.
applyTrackSource :: ∀ a rOut.
                    TrackSource a rOut
                 -> a
                 -> List (Variant rOut)
applyTrackSource (TrackSource h) a = mapMaybe (\f -> f a) h

module Genetics.Browser.Events.Handler
       ( TrackSink
       , emptyTrackSink
       , appendTrackSink
       , applyTrackSink
       , forkTrackSink
       , TrackSource
       , emptyTrackSource
       , appendTrackSource
       , applyTrackSource
       , class AppendHandlerImpl
       , class AppendHandler
       , concatHandler
       ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Data.List (List, (:), mapMaybe)
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.Record (insert)
import Data.Record.Unsafe (unsafeGet)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, expand, inj)
import Type.Prelude (class RowToList)
import Type.Row (class RowLacks, Cons, Nil, kind RowList)
import Unsafe.Coerce (unsafeCoerce)

-- | TrackSink is basically a record of functions which can handle some
-- | input in the form of Variants.
-- | `rin` is the row of types that this can handle,
-- | `rfun` is the row of types that corresponds to the record with functions
-- | `out` is the output type; all functions in `rfun` must have `out` as output
data TrackSink (rin :: # Type) (rfun :: # Type) out = TrackSink (Record rfun)

-- | Given a label and function, adds a handler to an existing TrackSink.
-- | The label must not already be handled by the TrackSink.
appendTrackSink :: ∀ l a rin1 rin2 b rfun1 rfun2.
                      RowLacks l rin1
                   => RowLacks l rfun1
                   => RowCons l (a -> b) rfun1 rfun2
                   => RowCons l a rin1 rin2
                   => IsSymbol l
                   => SProxy l
                   -> (a -> b)
                   -> TrackSink rin1 rfun1 b
                   -> TrackSink rin2 rfun2 b
appendTrackSink l f (TrackSink r) = TrackSink $ insert l f r

class AppendHandlerImpl
      (rin :: # Type) (rfun :: # Type)
      (lin :: RowList) (lfun :: RowList)
      a
      b
      (rin2 :: # Type) (rfun2 :: # Type)

instance appendHandlerNil
         :: AppendHandlerImpl rin rfun Nil Nil a b rin2 rfun2

instance appendHandlerCons
         :: ( AppendHandlerImpl rin rfun lin lfun a b rin2 rfun2
            , RowLacks label rin
            , RowLacks label rfun
            , RowCons label (a -> b) rfun rfun2
            , RowCons label a rin rin2
            , IsSymbol label
            )
         => AppendHandlerImpl rin rfun (Cons label a lin) (Cons label (a -> b) lfun) a b rin2 rfun2

class AppendHandler
      (rin :: # Type) (rfun :: # Type)
      (rin2 :: # Type) (rfun2 :: # Type)
      (rin3 :: # Type) (rfun3 :: # Type)
      out

instance appendHandlerInstance
         :: ( RowToList rin2 lin
            , RowToList rfun2 lfun
            , AppendHandlerImpl rin rfun lin lfun a out rin3 rfun3
            )
         => AppendHandler rin rfun rin2 rfun2 rin3 rfun3 out

foreign import concatHandler :: forall rin1 rfun1 rin2 rfun2 rin3 rfun3 out.
                                AppendHandler rin1 rfun1 rin2 rfun2 rin3 rfun3 out
                             => TrackSink rin1 rfun1 out
                             -> TrackSink rin2 rfun2 out
                             -> TrackSink rin3 rfun3 out
-- concatHandler (TrackSink h1) (TrackSink h2) =

-- instance appendHandlerInstance
--          :: ( RowToList l llist
--             , AppendHandlerImpl rin rfun lin lfun a b rin2 rfun2
--             )
--          => AppendHandler rin rfun lin lfun a b rin2 rfun2

emptyTrackSink :: ∀ b.
                TrackSink () () b
emptyTrackSink = TrackSink {}

-- | Runs a handler on an input, where the input is a Variant whose row is a subset of the
-- | TrackSink input row.
applyTrackSink :: ∀ lt a rin rfun b.
                     Union lt a rin
                  => TrackSink rin rfun b
                  -> Variant lt
                  -> b
applyTrackSink (TrackSink h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

-- | Forks an Aff process with a Handler that performs effects, using some environment.
-- | For example, `env` could be a Biodalliance instance.
forkTrackSink :: ∀ lt a rin rfun eff env.
                    Union lt a rin
                 => TrackSink rin rfun (env -> Eff (avar :: AVAR | eff) Unit)
                 -> env
                 -> BusRW (Variant lt)
                 -> Aff ( avar :: AVAR | eff ) (Canceler ( avar :: AVAR | eff ))
forkTrackSink h env bus = forkAff $ forever do
  val <- Bus.read bus
  liftEff $ applyTrackSink h val $ env

-- | An TrackSource has a list of parsers for some input, and can be used to
-- | produce heterogenous lists of parsed values
-- | `in` is the input type; the type of data that this handler can parse
-- | `rout` is the row of types that this can produce
data TrackSource a (rout :: # Type) = TrackSource (List (a -> Maybe (Variant rout)))

-- | Given a label and parser, adds a handler to an existing TrackSource.
-- | The label must not already be produced by the TrackSource.
appendTrackSource :: ∀ l a b r1 r r2.
                       Union r1 r r2
                    => RowLacks l r1
                    => RowCons l b r1 r2
                    => IsSymbol l
                    => SProxy l
                    -> (a -> Maybe b)
                    -> TrackSource a r1
                    -> TrackSource a r2
appendTrackSource l f (TrackSource h) = TrackSource $ f' : (map <<< map <<< map) expand h
  where f' :: a -> Maybe (Variant r2)
        f' a = inj l <$> f a

emptyTrackSource :: ∀ a.
                      TrackSource a ()
emptyTrackSource = TrackSource mempty

-- | Runs an TrackSource, producing a list of all successful parses of the input.
applyTrackSource :: ∀ a rout.
                      TrackSource a rout
                   -> a
                   -> List (Variant rout)
applyTrackSource (TrackSource h) a = mapMaybe (\f -> f a) h


length

length

module CodePoints
  ( CodePoint()
  --, Pattern()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  --, contains
  , count
  , drop
  --, dropWhile
  --, indexOf
  --, indexOf'
  --, lastIndexOf
  --, lastIndexOf'
  , length
  --, replace
  --, replaceAll
  --, singleton
  --, split
  --, splitAt
  --, stripPrefix
  --, stripSuffix
  , take
  --, takeWhile
  --, uncons
  , toCodePointArray
  --, fromCodePointArray
  ) where

import Prelude ((&&), (*), (+), (-), (<$>), (<=), (<<<))
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (toCharArray)
import Data.Unfoldable (unfoldr)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Tuple (Tuple(Tuple))
import Data.Array as Array
import Data.Char (toCharCode)

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (CodePoint (unsurrogate lead trail))
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> Int
unsurrogate h l = (h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count pred = Array.length <<< Array.filter pred <<< toCodePointArray

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

length :: String -> Int
length = Array.length <<< toCodePointArray

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (CodePoint (unsurrogate h l)) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

foreign import fromCodePointArray :: Array CodePoint -> String

module CodePoints
  ( CodePoint()
  --, Pattern()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  --, contains
  , count
  , drop
  --, dropWhile
  --, indexOf
  --, indexOf'
  --, lastIndexOf
  --, lastIndexOf'
  --, length
  --, replace
  --, replaceAll
  --, singleton
  --, split
  --, splitAt
  --, stripPrefix
  --, stripSuffix
  , take
  --, takeWhile
  --, uncons
  , toCodePointArray
  --, fromCodePointArray
  ) where

import Prelude ((&&), (*), (+), (-), (<$>), (<=), (<<<))
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (toCharArray)
import Data.Unfoldable (unfoldr)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Tuple (Tuple(Tuple))
import Data.Array as Array
import Data.Char (toCharCode)

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (CodePoint (unsurrogate lead trail))
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> Int
unsurrogate h l = (h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count pred = Array.length <<< Array.filter pred <<< toCodePointArray

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (CodePoint (unsurrogate h l)) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

foreign import fromCodePointArray :: Array CodePoint -> String


Add command to close psc-ide-server

Add command to close psc-ide-server

module IdePurescript.PscIdeServer where

import Prelude (const, bind, pure, ($), (++), (==), show, Unit, unit)
import Data.Maybe(Maybe(..))
import Data.Either (either)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Aff (Aff, attempt, later', makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Par (Par(Par), runPar)
import Control.Alt ((<|>))
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, Exit(Normally), onClose, onError, defaultSpawnOptions, spawn)
import IdePurescript.PscIde (cwd) as PscIde
import PscIde (NET, quit)

data ServerStartResult =
    CorrectPath
  | WrongPath String
  | Started ChildProcess
  | Closed
  | StartError String

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. String -> Int -> String -> Aff (cp :: CHILD_PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR | eff) ServerStartResult
startServer exe port rootPath = do
  workingDir <- attempt PscIde.cwd
  either (const launchServer) gotPath workingDir
  where

  launchServer = do
    liftEff $ log "Starting psc-ide-server"
    cp <- liftEff $ spawn exe ["-p", show port] (defaultSpawnOptions { cwd = Just rootPath })
    let handleErr = makeAff $ \_ succ -> do
                      onError cp (\_ -> succ $ StartError "psc-ide-server error")
                      onClose cp (\exit -> case exit of
                        (Normally 0) -> succ Closed
                        (Normally n) -> succ $ StartError $ "Error code returned: "++ show n
                        _ -> succ $ StartError "Other close error"
                      )

    runPar (Par handleErr <|> Par (later' 100 $ pure $ Started cp))

  gotPath workingDir =
    liftEff $ if workingDir == rootPath then
        do
          log $ "Found psc-ide-server with correct path: " ++ workingDir
          pure CorrectPath
      else
        do
          log $ "Found psc-ide-server with wrong path: " ++ workingDir ++ " instead of " ++ rootPath
          pure $ WrongPath workingDir

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET | eff) Unit
stopServer port cp = do
  res <- quit
  pure unit

module IdePurescript.PscIdeServer where

import Prelude (const, bind, pure, ($), (++), (==), show)
import Data.Maybe(Maybe(..))
import Data.Either (either)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Aff (Aff, attempt, later', makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Par (Par(Par), runPar)
import Control.Alt ((<|>))
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, Exit(Normally), onClose, onError, defaultSpawnOptions, spawn)
import IdePurescript.PscIde (cwd) as PscIde
import PscIde (NET)

data ServerStartResult =
    CorrectPath
  | WrongPath String
  | Started ChildProcess
  | Closed
  | StartError String

startServer :: forall eff. String -> Int -> String -> Aff (cp :: CHILD_PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR | eff) ServerStartResult
startServer exe port rootPath = do
  workingDir <- attempt PscIde.cwd
  either (const launchServer) gotPath workingDir
  where

  launchServer = do
    liftEff $ log "Starting psc-ide-server"
    cp <- liftEff $ spawn exe ["-p", show port] (defaultSpawnOptions { cwd = Just rootPath })
    let handleErr = makeAff $ \_ succ -> do
                      onError cp (\_ -> succ $ StartError "psc-ide-server error")
                      onClose cp (\exit -> case exit of
                        (Normally 0) -> succ Closed
                        (Normally n) -> succ $ StartError $ "Error code returned: "++ show n
                        _ -> succ $ StartError "Other close error"
                      )

    runPar (Par handleErr <|> Par (later' 100 $ pure $ Started cp))

  gotPath workingDir =
    liftEff $ if workingDir == rootPath then
        do
          log $ "Found psc-ide-server with correct path: " ++ workingDir
          pure CorrectPath
      else
        do
          log $ "Found psc-ide-server with wrong path: " ++ workingDir ++ " instead of " ++ rootPath
          pure $ WrongPath workingDir


refine the code and set the label's font

refine the code and set the label's font

{-
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.Card.Chart.BuildOptions.Funnel where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (ChartAxes, colors, buildChartAxes)

--sample data:
-- [ Tuple '' [Tuple 'dim1' 1.0, Tuple 'dim2' 5.0] ]
type FunnelData = Array (Tuple String (Array (Tuple String Number)))

buildFunnelData ∷ ChartAxes → FunnelData
buildFunnelData axes =
  A.fromFoldable
    $ map (map (A.fromFoldable
      -- output sample:
      -- ( Tuple ''
      --         ( Tuple 'dimA' 2
      --         : Tuple 'dimB' 10 )
      -- )
      <<< L.catMaybes
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'dimA' 1 : Tuple 'dimA' 1)
      --         : (Tuple 'dimB' 2 : Tuple 'dimB' 2 : Tuple 'dimB' 3 : Tuple 'dimB' 3) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'dimA' 1 : Tuple 'dimB' 2
    --         : Tuple 'dimB' 3 : Tuple 'dimA' 1
    --         : Tuple 'dimB' 2 : Tuple 'dimB' 3 )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'dimA' 1) : Tuple '' (Tuple 'dimB' 2)
    --  : Tuple '' (Tuple 'dimB' 3) : Tuple '' (Tuple 'dimA' 1)
    --  : Tuple '' (Tuple 'dimB' 2) : Tuple '' (Tuple 'dimB' 3) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'dimA' 1) : Tuple '' (Tuple 'dimB' 2)
    -- : Tuple '' (Tuple 'dimB' 3) : Tuple '' (Tuple 'dimA' 1)
    -- : Tuple '' (Tuple 'dimB' 2) : Tuple '' (Tuple 'dimB' 3) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ L.zip dimensions values
  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 0

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple (Maybe String) (Tuple (Maybe String) (Maybe Number)))
  tagDuplications d v =
    if L.null d
      then map (Tuple Nothing) v
      else L.zip d v

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple (Maybe String) (Maybe Number))
    → Maybe (Tuple String (Tuple String Number))
  filterInvalid (a × b × c) =
    case b, c of
      Just b', Just c' →
        Just $ Tuple (fromMaybe "" a) (Tuple b' c')
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineDup x = do
    d ← fst <$> L.head x
    pure $ Tuple d $ map snd x

  combineDim
    ∷ List (Tuple String Number)
    → Maybe (Tuple String Number)
  combineDim x = do
    d ← fst <$> L.head x
    pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation = runAggregation (fromMaybe Sum agg)

buildFunnel
  ∷ Map JCursor Ax.Axis
  → String
  → String
  → ChartConfiguration
  → DSL OptionI
buildFunnel axes order align conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem dimNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.funnel ∘ serie numDup)
    $ A.zip (A.range 0 (A.length funnelData)) (funnelData)

  where
  dimNames ∷ Array String
  dimNames =
    A.nub
      $ A.concatMap (map fst)
      $ map snd funnelData

  dupNames ∷ Array String
  dupNames = map fst funnelData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = ((n - 1) / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
        rowHight = 100.0 / (toNumber nRow)
        spaceCoeff = 0.9
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (rowHight * spaceCoeff) / 2.0
      E.textCenter
      E.textBottom

  funnelData ∷ FunnelData
  funnelData = buildFunnelData $ buildChartAxes axes conf

  serie
    ∷ Int
    → Tuple Int (Tuple String (Array (Tuple String Number)))
    → DSL ETP.FunnelI
  serie n (i × (dup × a)) = do
    let
      -- max number of plot in one row: 4
      maxCol = 4
      nRow = ((n - 1) / maxCol + 1)
      nCol = if n <= maxCol then n else maxCol
      row = toNumber (i / nCol)
      col = (toNumber i) % (toNumber nCol)
      rowHight = 100.0 / (toNumber nRow)
      colWidth = 100.0 / (toNumber nCol)
      spaceCoeff = 0.75
    E.left
      $ ET.Percent
      $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        - (colWidth * spaceCoeff) / 2.0
    E.top
      $ ET.Percent
      $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        - (rowHight * spaceCoeff) / 2.0
    E.widthPixelOrPercent
      $ ET.Percent
      $ colWidth * spaceCoeff
    E.heightPixelOrPercent
      $ ET.Percent
      $ rowHight * spaceCoeff
    when (dup ≠ "") $ E.name dup
    case order of
      "ascending" → E.ascending
      _ → E.descending
    case align of
      "left" → E.funnelLeft
      "right" → E.funnelRight
      _ → E.funnelCenter
    E.buildItems $ for_ a \x →
      E.addItem $ makeData x
    E.label do
      E.normalLabel do
        E.textStyle do
          E.fontFamily "Ubuntu sans"

  makeData
    ∷ Tuple String Number
    → DSL ETP.ItemI
  makeData (name × value) = do
    E.name name
    E.value value

{-
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.Card.Chart.BuildOptions.Funnel where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (ChartAxes, colors, buildChartAxes)

--sample data:
-- [ Tuple '' [Tuple 'dim1' 1.0, Tuple 'dim2' 5.0] ]
type FunnelData = Array (Tuple String (Array (Tuple String Number)))

buildFunnelData ∷ ChartAxes → FunnelData
buildFunnelData axes =
  A.fromFoldable
    $ map (map (A.fromFoldable
      -- output sample:
      -- ( Tuple ''
      --         ( Tuple 'dimA' 2
      --         : Tuple 'dimB' 10 )
      -- )
      <<< L.catMaybes
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'dimA' 1 : Tuple 'dimA' 1)
      --         : (Tuple 'dimB' 2 : Tuple 'dimB' 2 : Tuple 'dimB' 3 : Tuple 'dimB' 3) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'dimA' 1 : Tuple 'dimB' 2
    --         : Tuple 'dimB' 3 : Tuple 'dimA' 1
    --         : Tuple 'dimB' 2 : Tuple 'dimB' 3 )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'dimA' 1) : Tuple '' (Tuple 'dimB' 2)
    --  : Tuple '' (Tuple 'dimB' 3) : Tuple '' (Tuple 'dimA' 1)
    --  : Tuple '' (Tuple 'dimB' 2) : Tuple '' (Tuple 'dimB' 3) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'dimA' 1) : Tuple '' (Tuple 'dimB' 2)
    -- : Tuple '' (Tuple 'dimB' 3) : Tuple '' (Tuple 'dimA' 1)
    -- : Tuple '' (Tuple 'dimB' 2) : Tuple '' (Tuple 'dimB' 3) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ L.zip dimensions values
  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 0

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple (Maybe String) (Tuple (Maybe String) (Maybe Number)))
  tagDuplications d v =
    if L.null d
      then map (Tuple Nothing) v
      else L.zip d v

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple (Maybe String) (Maybe Number))
    → Maybe (Tuple String (Tuple String Number))
  filterInvalid (a × b × c) =
    case b, c of
      Just b', Just c' →
        Just $ Tuple (fromMaybe "" a) (Tuple b' c')
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineDup x = do
    d ← fst <$> L.head x
    pure $ Tuple d $ map snd x

  combineDim
    ∷ List (Tuple String Number)
    → Maybe (Tuple String Number)
  combineDim x = do
    d ← fst <$> L.head x
    pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation = runAggregation (fromMaybe Sum agg)

buildFunnel
  ∷ Map JCursor Ax.Axis
  → String
  → String
  → ChartConfiguration
  → DSL OptionI
buildFunnel axes order align conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem dimNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.funnel ∘ serie numDup)
    $ A.zip (A.range 0 (A.length funnelData)) (funnelData)

  where
  dimNames ∷ Array String
  dimNames =
    A.nub
      $ A.concat
      $ map (map fst)
      $ map snd funnelData

  dupNames ∷ Array String
  dupNames = map fst funnelData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = ((n - 1) / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
        rowHight = 100.0 / (toNumber nRow)
        spaceCoeff = 0.9
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (rowHight * spaceCoeff) / 2.0
      E.textCenter
      E.textBottom

  funnelData ∷ FunnelData
  funnelData = buildFunnelData $ buildChartAxes axes conf

  serie
    ∷ Int
    → Tuple Int (Tuple String (Array (Tuple String Number)))
    → DSL ETP.FunnelI
  serie n (i × (dup × a)) = do
    let
      -- max number of plot in one row: 4
      maxCol = 4
      nRow = ((n - 1) / maxCol + 1)
      nCol = if n <= maxCol then n else maxCol
      row = toNumber (i / nCol)
      col = (toNumber i) % (toNumber nCol)
      rowHight = 100.0 / (toNumber nRow)
      colWidth = 100.0 / (toNumber nCol)
      spaceCoeff = 0.75
    E.left
      $ ET.Percent
      $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        - (colWidth * spaceCoeff) / 2.0
    E.top
      $ ET.Percent
      $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        - (rowHight * spaceCoeff) / 2.0
    E.widthPixelOrPercent
      $ ET.Percent
      $ colWidth * spaceCoeff
    E.heightPixelOrPercent
      $ ET.Percent
      $ rowHight * spaceCoeff
    when (dup ≠ "") $ E.name dup
    case order of
      "ascending" → E.ascending
      _ → E.descending
    case align of
      "left" → E.funnelLeft
      "right" → E.funnelRight
      _ → E.funnelCenter
    E.buildItems $ for_ a \x →
      E.addItem $ makeData x

  makeData
    ∷ Tuple String Number
    → DSL ETP.ItemI
  makeData (name × value) = do
    E.name name
    E.value value


Add some missing event types

Add some missing event types

module DOM.HTML.Event.EventTypes where

import DOM.Event.Types (EventType(..))

abort :: EventType
abort = EventType "abort"

animationend :: EventType
animationend = EventType "animationend"

animationiteration :: EventType
animationiteration = EventType "animationiteration"

animationstart :: EventType
animationstart = EventType "animationstart"

beforeunload :: EventType
beforeunload = EventType "beforeunload"

blur :: EventType
blur = EventType "blur"

change :: EventType
change = EventType "change"

click :: EventType
click = EventType "click"

complete :: EventType
complete = EventType "complete"

compositionend :: EventType
compositionend = EventType "compositionend"

compositionstart :: EventType
compositionstart = EventType "compositionstart"

compositionupdate :: EventType
compositionupdate = EventType "compositionupdate"

contextmenu :: EventType
contextmenu = EventType "contextmenu"

copy :: EventType
copy = EventType "copy"

cut :: EventType
cut = EventType "cut"

dblclick :: EventType
dblclick = EventType "dblclick"

drag :: EventType
drag = EventType "drag"

dragend :: EventType
dragend = EventType "dragend"

dragenter :: EventType
dragenter = EventType "dragenter"

dragexit :: EventType
dragexit = EventType "dragexit"

dragleave :: EventType
dragleave = EventType "dragleave"

dragover :: EventType
dragover = EventType "dragover"

dragstart :: EventType
dragstart = EventType "dragstart"

drop :: EventType
drop = EventType "drop"

error :: EventType
error = EventType "error"

focus :: EventType
focus = EventType "focus"

focusin :: EventType
focusin = EventType "focusin"

focusout :: EventType
focusout = EventType "focusout"

hashchange :: EventType
hashchange = EventType "hashchange"

input :: EventType
input = EventType "input"

invalid :: EventType
invalid = EventType "invalid"

keydown :: EventType
keydown = EventType "keydown"

keypress :: EventType
keypress = EventType "keypress"

keyup :: EventType
keyup = EventType "keyup"

load :: EventType
load = EventType "load"

loadeddata :: EventType
loadeddata = EventType "loadeddata"

loadedmetadata :: EventType
loadedmetadata = EventType "loadedmetadata"

loadend :: EventType
loadend = EventType "loadend"

loadstart :: EventType
loadstart = EventType "loadstart"

message :: EventType
message = EventType "message"

mousedown :: EventType
mousedown = EventType "mousedown"

mouseenter :: EventType
mouseenter = EventType "mouseenter"

mouseleave :: EventType
mouseleave = EventType "mouseleave"

mousemove :: EventType
mousemove = EventType "mousemove"

mouseout :: EventType
mouseout = EventType "mouseout"

mouseover :: EventType
mouseover = EventType "mouseover"

mouseup :: EventType
mouseup = EventType "mouseup"

open :: EventType
open = EventType "open"

pagehide :: EventType
pagehide = EventType "pagehide"

pageshow :: EventType
pageshow = EventType "pageshow"

paste :: EventType
paste = EventType "paste"

pause :: EventType
pause = EventType "pause"

play :: EventType
play = EventType "play"

playing :: EventType
playing = EventType "playing"

popstate :: EventType
popstate = EventType "popstate"

progress :: EventType
progress = EventType "progress"

ratechange :: EventType
ratechange = EventType "ratechange"

readystatechange :: EventType
readystatechange = EventType "readystatechange"

reset :: EventType
reset = EventType "reset"

resize :: EventType
resize = EventType "resize"

scroll :: EventType
scroll = EventType "scroll"

seeked :: EventType
seeked = EventType "seeked"

seeking :: EventType
seeking = EventType "seeking"

select :: EventType
select = EventType "select"

show :: EventType
show = EventType "show"

stalled :: EventType
stalled = EventType "stalled"

submit :: EventType
submit = EventType "submit"

suspend :: EventType
suspend = EventType "suspend"

timeout :: EventType
timeout = EventType "timeout"

timeupdate :: EventType
timeupdate = EventType "timeupdate"

touchcancel :: EventType
touchcancel = EventType "touchcancel"

touchend :: EventType
touchend = EventType "touchend"

touchenter :: EventType
touchenter = EventType "touchenter"

touchleave :: EventType
touchleave = EventType "touchleave"

touchmove :: EventType
touchmove = EventType "touchmove"

touchstart :: EventType
touchstart = EventType "touchstart"

transitionend :: EventType
transitionend = EventType "transitionend"

unload :: EventType
unload = EventType "unload"

visibilitychange :: EventType
visibilitychange = EventType "visibilitychange"

wheel :: EventType
wheel = EventType "wheel"

module DOM.HTML.Event.EventTypes where

import DOM.Event.Types (EventType(..))

abort :: EventType
abort = EventType "abort"

animationend :: EventType
animationend = EventType "animationend"

animationiteration :: EventType
animationiteration = EventType "animationiteration"

animationstart :: EventType
animationstart = EventType "animationstart"

beforeunload :: EventType
beforeunload = EventType "beforeunload"

blur :: EventType
blur = EventType "blur"

change :: EventType
change = EventType "change"

click :: EventType
click = EventType "click"

complete :: EventType
complete = EventType "complete"

compositionend :: EventType
compositionend = EventType "compositionend"

compositionstart :: EventType
compositionstart = EventType "compositionstart"

compositionupdate :: EventType
compositionupdate = EventType "compositionupdate"

contextmenu :: EventType
contextmenu = EventType "contextmenu"

copy :: EventType
copy = EventType "copy"

cut :: EventType
cut = EventType "cut"

dblclick :: EventType
dblclick = EventType "dblclick"

drag :: EventType
drag = EventType "drag"

dragend :: EventType
dragend = EventType "dragend"

dragenter :: EventType
dragenter = EventType "dragenter"

dragleave :: EventType
dragleave = EventType "dragleave"

dragover :: EventType
dragover = EventType "dragover"

dragstart :: EventType
dragstart = EventType "dragstart"

drop :: EventType
drop = EventType "drop"

error :: EventType
error = EventType "error"

focus :: EventType
focus = EventType "focus"

hashchange :: EventType
hashchange = EventType "hashchange"

input :: EventType
input = EventType "input"

keydown :: EventType
keydown = EventType "keydown"

keypress :: EventType
keypress = EventType "keypress"

keyup :: EventType
keyup = EventType "keyup"

load :: EventType
load = EventType "load"

loadeddata :: EventType
loadeddata = EventType "loadeddata"

loadedmetadata :: EventType
loadedmetadata = EventType "loadedmetadata"

loadend :: EventType
loadend = EventType "loadend"

loadstart :: EventType
loadstart = EventType "loadstart"

message :: EventType
message = EventType "message"

mousedown :: EventType
mousedown = EventType "mousedown"

mouseenter :: EventType
mouseenter = EventType "mouseenter"

mouseleave :: EventType
mouseleave = EventType "mouseleave"

mousemove :: EventType
mousemove = EventType "mousemove"

mouseout :: EventType
mouseout = EventType "mouseout"

mouseover :: EventType
mouseover = EventType "mouseover"

mouseup :: EventType
mouseup = EventType "mouseup"

open :: EventType
open = EventType "open"

pagehide :: EventType
pagehide = EventType "pagehide"

pageshow :: EventType
pageshow = EventType "pageshow"

paste :: EventType
paste = EventType "paste"

pause :: EventType
pause = EventType "pause"

play :: EventType
play = EventType "play"

playing :: EventType
playing = EventType "playing"

popstate :: EventType
popstate = EventType "popstate"

progress :: EventType
progress = EventType "progress"

ratechange :: EventType
ratechange = EventType "ratechange"

readystatechange :: EventType
readystatechange = EventType "readystatechange"

reset :: EventType
reset = EventType "reset"

resize :: EventType
resize = EventType "resize"

scroll :: EventType
scroll = EventType "scroll"

seeked :: EventType
seeked = EventType "seeked"

seeking :: EventType
seeking = EventType "seeking"

select :: EventType
select = EventType "select"

show :: EventType
show = EventType "show"

stalled :: EventType
stalled = EventType "stalled"

submit :: EventType
submit = EventType "submit"

suspend :: EventType
suspend = EventType "suspend"

timeout :: EventType
timeout = EventType "timeout"

timeupdate :: EventType
timeupdate = EventType "timeupdate"

touchcancel :: EventType
touchcancel = EventType "touchcancel"

touchend :: EventType
touchend = EventType "touchend"

touchenter :: EventType
touchenter = EventType "touchenter"

touchleave :: EventType
touchleave = EventType "touchleave"

touchmove :: EventType
touchmove = EventType "touchmove"

touchstart :: EventType
touchstart = EventType "touchstart"

transitionend :: EventType
transitionend = EventType "transitionend"

unload :: EventType
unload = EventType "unload"

visibilitychange :: EventType
visibilitychange = EventType "visibilitychange"

wheel :: EventType
wheel = EventType "wheel"