Add Node Stream API link to module documentation

-- | This module provides a low-level wrapper for the [Node Stream API](https://nodejs.org/api/stream.html).

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , onData
  , onDataString
  , onDataEither
  , setEncoding
  , onReadable
  , onEnd
  , onFinish
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , unpipe
  , unpipeAll
  , read
  , readString
  , readEither
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  , destroy
  ) where

import Prelude

import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Exception (throw, EXCEPTION(), Error())
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Node.Buffer (Buffer())
import Node.Buffer as Buffer
import Node.Encoding (Encoding)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # Type -> # Effect -> Type

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import undefined :: forall a. a

foreign import data Chunk :: Type

foreign import readChunkImpl
  :: (forall l r. l -> Either l r)
  -> (forall l r. r -> Either l r)
  -> Chunk
  -> Either String Buffer

readChunk :: Chunk -> Either String Buffer
readChunk = readChunkImpl Left Right

-- | Listen for `data` events, returning data in a Buffer. Note that this will fail
-- | if `setEncoding` has been called on the stream.
onData
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> (Buffer -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onData r cb =
  onDataEither r (cb <=< fromEither)
  where
  fromEither x =
    case x of
      Left _  ->
        throw "Stream encoding should not be set"
      Right buf ->
        pure buf

read
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
   -> Maybe Int
   -> Eff (exception :: EXCEPTION | eff) (Maybe Buffer)
read r size = do
  v <- readEither r size
  case v of
    Nothing        -> pure Nothing
    Just (Left _)  -> throw "Stream encoding should not be set"
    Just (Right b) -> pure (Just b)

readString
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> Maybe Int
  -> Encoding
  -> Eff (exception :: EXCEPTION | eff) (Maybe String)
readString r size enc = do
  v <- readEither r size
  case v of
       Nothing          -> pure Nothing
       Just (Left _)    -> throw "Stream encoding should not be set"
       Just (Right buf) -> Just <$> (unsafeCoerceEff $ Buffer.toString enc buf)

readEither
  :: forall w eff
   . Readable w eff
  -> Maybe Int
  -> Eff eff (Maybe (Either String Buffer))
readEither r size = readImpl readChunk Nothing Just r (fromMaybe undefined size)

foreign import readImpl
  :: forall r eff
   . (Chunk -> Either String Buffer)
  -> (forall a. Maybe a)
  -> (forall a. a -> Maybe a)
  -> Readable r eff
  -> Int
  -> Eff eff (Maybe (Either String Buffer))

-- | Listen for `data` events, returning data in a String, which will be
-- | decoded using the given encoding. Note that this will fail if `setEncoding`
-- | has been called on the stream.
onDataString
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> Encoding
  -> (String -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onDataString r enc cb = onData r (cb <=< unsafeCoerceEff <<< Buffer.toString enc)

-- | Listen for `data` events, returning data in an `Either String Buffer`. This
-- | function is provided for the (hopefully rare) case that `setEncoding` has
-- | been called on the stream.
onDataEither
  :: forall r eff
   . Readable r (exception :: EXCEPTION | eff)
  -> (Either String Buffer -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onDataEither r cb = onDataEitherImpl readChunk r cb

foreign import onDataEitherImpl
  :: forall r eff
   . (Chunk -> Either String Buffer)
  -> Readable r eff
  -> (Either String Buffer -> Eff eff Unit)
  -> Eff eff Unit

foreign import setEncodingImpl
  :: forall w eff
   . Readable w eff
  -> String
  -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream. This
-- | function may be useful when you are passing a readable stream to some other
-- | JavaScript library, which already expects an encoding to be set.
-- |
-- | Where possible, you should try to use `onDataString` instead of this
-- | function.
setEncoding
  :: forall w eff
   . Readable w eff
  -> Encoding
  -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

-- | Listen for `readable` events.
foreign import onReadable
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `end` events.
foreign import onEnd
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `finish` events.
foreign import onFinish
  :: forall w eff
   . Writable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose
  :: forall w eff
   . Stream w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError
  :: forall w eff
   . Stream w eff
  -> (Error -> Eff eff Unit)
  -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe
  :: forall r w eff
   . Readable w eff
  -> Writable r eff
  -> Eff eff (Writable r eff)

-- | Detach a Writable stream previously attached using `pipe`.
foreign import unpipe
  :: forall r w eff
   . Readable w eff
  -> Writable r eff
  -> Eff eff Unit

-- | Detach all Writable streams previously attached using `pipe`.
foreign import unpipeAll
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit

-- | Write a Buffer to a writable stream.
foreign import write
  :: forall r eff
   . Writable r eff
  -> Buffer
  -> Eff eff Unit
  -> Eff eff Boolean

foreign import writeStringImpl
  :: forall r eff
   . Writable r eff
  -> String
  -> String
  -> Eff eff Unit
  -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString
  :: forall r eff
   . Writable r eff
  -> Encoding
  -> String
  -> Eff eff Unit
  -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl
  :: forall r eff
   . Writable r eff
  -> String
  -> Eff eff Unit

-- | Set the default encoding used to write strings to the stream. This function
-- | is useful when you are passing a writable stream to some other JavaScript
-- | library, which already expects a default encoding to be set. It has no
-- | effect on the behaviour of the `writeString` function (because that
-- | function ensures that the encoding is always supplied explicitly).
setDefaultEncoding
  :: forall r eff
   . Writable r eff
  -> Encoding
  -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end
  :: forall r eff
   . Writable r eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Destroy the stream. It will release any internal resources.
--
-- Added in node 8.0.
foreign import destroy
  :: forall r eff
   . Stream r eff
  -> Eff eff Unit

-- | Destroy the stream and emit 'error'.
--
-- Added in node 8.0.
foreign import destroyWithError
  :: forall r eff
   . Stream r eff
  -> Error
  -> Eff eff Unit

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , onData
  , onDataString
  , onDataEither
  , setEncoding
  , onReadable
  , onEnd
  , onFinish
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , unpipe
  , unpipeAll
  , read
  , readString
  , readEither
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  , destroy
  ) where

import Prelude

import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Exception (throw, EXCEPTION(), Error())
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Node.Buffer (Buffer())
import Node.Buffer as Buffer
import Node.Encoding (Encoding)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # Type -> # Effect -> Type

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import undefined :: forall a. a

foreign import data Chunk :: Type

foreign import readChunkImpl
  :: (forall l r. l -> Either l r)
  -> (forall l r. r -> Either l r)
  -> Chunk
  -> Either String Buffer

readChunk :: Chunk -> Either String Buffer
readChunk = readChunkImpl Left Right

-- | Listen for `data` events, returning data in a Buffer. Note that this will fail
-- | if `setEncoding` has been called on the stream.
onData
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> (Buffer -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onData r cb =
  onDataEither r (cb <=< fromEither)
  where
  fromEither x =
    case x of
      Left _  ->
        throw "Stream encoding should not be set"
      Right buf ->
        pure buf

read
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
   -> Maybe Int
   -> Eff (exception :: EXCEPTION | eff) (Maybe Buffer)
read r size = do
  v <- readEither r size
  case v of
    Nothing        -> pure Nothing
    Just (Left _)  -> throw "Stream encoding should not be set"
    Just (Right b) -> pure (Just b)

readString
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> Maybe Int
  -> Encoding
  -> Eff (exception :: EXCEPTION | eff) (Maybe String)
readString r size enc = do
  v <- readEither r size
  case v of
       Nothing          -> pure Nothing
       Just (Left _)    -> throw "Stream encoding should not be set"
       Just (Right buf) -> Just <$> (unsafeCoerceEff $ Buffer.toString enc buf)

readEither
  :: forall w eff
   . Readable w eff
  -> Maybe Int
  -> Eff eff (Maybe (Either String Buffer))
readEither r size = readImpl readChunk Nothing Just r (fromMaybe undefined size)

foreign import readImpl
  :: forall r eff
   . (Chunk -> Either String Buffer)
  -> (forall a. Maybe a)
  -> (forall a. a -> Maybe a)
  -> Readable r eff
  -> Int
  -> Eff eff (Maybe (Either String Buffer))

-- | Listen for `data` events, returning data in a String, which will be
-- | decoded using the given encoding. Note that this will fail if `setEncoding`
-- | has been called on the stream.
onDataString
  :: forall w eff
   . Readable w (exception :: EXCEPTION | eff)
  -> Encoding
  -> (String -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onDataString r enc cb = onData r (cb <=< unsafeCoerceEff <<< Buffer.toString enc)

-- | Listen for `data` events, returning data in an `Either String Buffer`. This
-- | function is provided for the (hopefully rare) case that `setEncoding` has
-- | been called on the stream.
onDataEither
  :: forall r eff
   . Readable r (exception :: EXCEPTION | eff)
  -> (Either String Buffer -> Eff (exception :: EXCEPTION | eff) Unit)
  -> Eff (exception :: EXCEPTION | eff) Unit
onDataEither r cb = onDataEitherImpl readChunk r cb

foreign import onDataEitherImpl
  :: forall r eff
   . (Chunk -> Either String Buffer)
  -> Readable r eff
  -> (Either String Buffer -> Eff eff Unit)
  -> Eff eff Unit

foreign import setEncodingImpl
  :: forall w eff
   . Readable w eff
  -> String
  -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream. This
-- | function may be useful when you are passing a readable stream to some other
-- | JavaScript library, which already expects an encoding to be set.
-- |
-- | Where possible, you should try to use `onDataString` instead of this
-- | function.
setEncoding
  :: forall w eff
   . Readable w eff
  -> Encoding
  -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

-- | Listen for `readable` events.
foreign import onReadable
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `end` events.
foreign import onEnd
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `finish` events.
foreign import onFinish
  :: forall w eff
   . Writable w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose
  :: forall w eff
   . Stream w eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError
  :: forall w eff
   . Stream w eff
  -> (Error -> Eff eff Unit)
  -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe
  :: forall r w eff
   . Readable w eff
  -> Writable r eff
  -> Eff eff (Writable r eff)

-- | Detach a Writable stream previously attached using `pipe`.
foreign import unpipe
  :: forall r w eff
   . Readable w eff
  -> Writable r eff
  -> Eff eff Unit

-- | Detach all Writable streams previously attached using `pipe`.
foreign import unpipeAll
  :: forall w eff
   . Readable w eff
  -> Eff eff Unit

-- | Write a Buffer to a writable stream.
foreign import write
  :: forall r eff
   . Writable r eff
  -> Buffer
  -> Eff eff Unit
  -> Eff eff Boolean

foreign import writeStringImpl
  :: forall r eff
   . Writable r eff
  -> String
  -> String
  -> Eff eff Unit
  -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString
  :: forall r eff
   . Writable r eff
  -> Encoding
  -> String
  -> Eff eff Unit
  -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl
  :: forall r eff
   . Writable r eff
  -> String
  -> Eff eff Unit

-- | Set the default encoding used to write strings to the stream. This function
-- | is useful when you are passing a writable stream to some other JavaScript
-- | library, which already expects a default encoding to be set. It has no
-- | effect on the behaviour of the `writeString` function (because that
-- | function ensures that the encoding is always supplied explicitly).
setDefaultEncoding
  :: forall r eff
   . Writable r eff
  -> Encoding
  -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end
  :: forall r eff
   . Writable r eff
  -> Eff eff Unit
  -> Eff eff Unit

-- | Destroy the stream. It will release any internal resources.
--
-- Added in node 8.0.
foreign import destroy
  :: forall r eff
   . Stream r eff
  -> Eff eff Unit

-- | Destroy the stream and emit 'error'.
--
-- Added in node 8.0.
foreign import destroyWithError
  :: forall r eff
   . Stream r eff
  -> Error
  -> Eff eff Unit


Fix crash on trying to render too many glyphs

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (zip)
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), fromJust)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(Bp), BpPerPixel(BpPerPixel), Chr(Chr), bpToPixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            -- score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            score <- obj ^? ix "score" <<< _Number
            -- pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))
            -- pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))
            pure $ Feature (Chr "chr11") min max (score * 100.0)

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = 100.0
                x = bpToPixels v.scale (min - v.min)
                -- z = traceShow x \_ -> unit
                -- x = 100.0
                -- x = 100.0
            stroke "black"
            fill "red"
            circle { x, y } 3.0

-- add function (Array (Glyph Unit)) -> Context2D -> Context2D -> Eff _ Unit,
-- where a single glyph is drawn many times by filling a backbuffer and copying it.
-- probably won't work with GlyphF; the glyphs are in fact not the same,
-- each one has its own position etc.
-- can we have a way to simplify this so each track only gets one glyph?
-- an explicit mapping from feature to pair of glyph and offset, or something like that.
-- then we could construct a tree, with the stroke & fill at the root. woop.
-- worth thinking about. & reading about optimizing these things
-- basically traversing/sequence something like
-- [Stroke "black" (Circle _ _ _), Stroke "black" (Circle _ _ _) ...]
-- into
-- Stroke "black" [Circle _ _ _, Circle _ _ _...]
-- though that is fundamentally different from the idea of drawing a single glyph
-- to a backbuffer.
-- *that* idea makes more sense with the idea of a glyph being somehow atomic;
-- a glyph should only describe what it looks like, in its own system -- not its
-- height, nothing like that. hmm.
-- the glyph would be more a function of the track than the feature.
-- however, it shouldn't necessarily be so; a track should be able to display different
-- glyphs depending on the feature values.
-- Buuut they should also memoize based on feature, so if the features in a track
-- only produce like 10 glyphs that are identical except for color, then those
-- renderings should be optimized.
-- need research!!!

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx gs = withContext ctx do
  -- log $ show $ (length gs) :: Int
  _ <- translate tt ctx
  foreachE (Array.fromFoldable gs) $ void <$> renderGlyph ctx

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

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

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

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

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

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

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

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

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

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

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

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

-- TODO: fetching could (should) be done completely async,
-- and done on subscribing to the Event View. Like now,
-- but less clumsy -- model rendering around the fetch function,
-- and add some caching to it

-- fetcho :: String -> Event View -> Aff _ _
-- fetcho uri ev = launchAff do

browser :: String -> Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 20000.0
      maxView = Bp 3000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri
      renderer :: _
      -- renderer = renderGlyphs (browserTransform h) ctx
      renderer = renderGlyphs {translateX: 0.0, translateY: 0.0} ctx
      fetch :: View -> Aff _ _
      fetch v = do

        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        liftEff $ log $ unsafeStringify gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer gs

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do

    _ <- launchAff $ fetch v'

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  -- _ <- liftEff $ unsafeCoerceEff $
  --      FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
  --        state <- tryPeekVar browserState
  --        liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
  --        case state of
  --          Nothing -> liftEff $ log "no state!"
  --          Just s' -> do
  --            liftEff $ log "state!"
  --            let gs' :: _
  --                gs' = clickAnnGlyphs s'.annotatedGlyphs p

  --            traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch v

main :: Eff _ _
main = launchAff $ browser "./alot.json"

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (zip)
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), fromJust)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(Bp), BpPerPixel(BpPerPixel), Chr(Chr), bpToPixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            -- score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            score <- obj ^? ix "score" <<< _Number
            -- pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))
            -- pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))
            pure $ Feature (Chr "chr11") min max (score * 100.0)

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = 100.0
                x = bpToPixels v.scale (min - v.min)
                -- z = traceShow x \_ -> unit
                -- x = 100.0
                -- x = 100.0
            stroke "black"
            fill "red"
            circle { x, y } 3.0

-- add function (Array (Glyph Unit)) -> Context2D -> Context2D -> Eff _ Unit,
-- where a single glyph is drawn many times by filling a backbuffer and copying it.
-- probably won't work with GlyphF; the glyphs are in fact not the same,
-- each one has its own position etc.
-- can we have a way to simplify this so each track only gets one glyph?
-- an explicit mapping from feature to pair of glyph and offset, or something like that.
-- then we could construct a tree, with the stroke & fill at the root. woop.
-- worth thinking about. & reading about optimizing these things
-- basically traversing/sequence something like
-- [Stroke "black" (Circle _ _ _), Stroke "black" (Circle _ _ _) ...]
-- into
-- Stroke "black" [Circle _ _ _, Circle _ _ _...]
-- though that is fundamentally different from the idea of drawing a single glyph
-- to a backbuffer.
-- *that* idea makes more sense with the idea of a glyph being somehow atomic;
-- a glyph should only describe what it looks like, in its own system -- not its
-- height, nothing like that. hmm.
-- the glyph would be more a function of the track than the feature.
-- however, it shouldn't necessarily be so; a track should be able to display different
-- glyphs depending on the feature values.
-- Buuut they should also memoize based on feature, so if the features in a track
-- only produce like 10 glyphs that are identical except for color, then those
-- renderings should be optimized.
-- need research!!!

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx gs = withContext ctx do
  -- log $ show $ (length gs) :: Int
  _ <- translate tt ctx
  traverse_ (renderGlyph ctx) gs

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

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

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

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

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

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

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

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

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

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

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

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

-- TODO: fetching could (should) be done completely async,
-- and done on subscribing to the Event View. Like now,
-- but less clumsy -- model rendering around the fetch function,
-- and add some caching to it

-- fetcho :: String -> Event View -> Aff _ _
-- fetcho uri ev = launchAff do

browser :: String -> Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 20000.0
      maxView = Bp 3000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri
      renderer :: _
      -- renderer = renderGlyphs (browserTransform h) ctx
      renderer = renderGlyphs {translateX: 0.0, translateY: 0.0} ctx
      fetch :: View -> Aff _ _
      fetch v = do

        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        liftEff $ log $ unsafeStringify gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer gs

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do

    _ <- launchAff $ fetch v'

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  -- _ <- liftEff $ unsafeCoerceEff $
  --      FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
  --        state <- tryPeekVar browserState
  --        liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
  --        case state of
  --          Nothing -> liftEff $ log "no state!"
  --          Just s' -> do
  --            liftEff $ log "state!"
  --            let gs' :: _
  --                gs' = clickAnnGlyphs s'.annotatedGlyphs p

  --            traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch v

main :: Eff _ _
main = launchAff $ browser "./alot.json"