Hook up

Hook up

module Component.LoginWidget where

import Chat.ServerTypes
import Prelude
import Data.Maybe (Maybe(..))

import Halogen.HTML.Events as E
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import DOM.Event.KeyboardEvent as K

type State = {auth :: Maybe AuthToken, login :: String}

onSpecificKeyPress :: forall r i. String -> (K.KeyboardEvent -> Maybe i) -> P.IProp (onKeyPress :: K.KeyboardEvent | r) i
onSpecificKeyPress code f = E.onKeyPress (\ke -> if K.code ke == code then f ke else Nothing)

render update setAuth = H.div_ $ [ H.text "Username", H.input [E.onValueInput (E.input update), onSpecificKeyPress "Enter" (E.input_ setAuth)], H.button [E.onClick (E.input_ setAuth)] [H.text "Login"] ]

module Component.LoginWidget where

import Chat.ServerTypes
import Prelude
import Data.Maybe (Maybe(..))

import Halogen.HTML.Events as E
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import DOM.Event.KeyboardEvent as K

type State = {auth :: Maybe AuthToken, login :: String}

onSpecificKeyPress :: forall r i. String -> (K.KeyboardEvent -> Maybe i) -> P.IProp (onKeyPress :: K.KeyboardEvent | r) i
onSpecificKeyPress code = E.onKeyPress

render update setAuth = H.div_ $ [ H.text "Username", H.input [E.onValueInput (E.input update), onSpecificKeyPress "Enter" (E.input_ setAuth)], H.button [E.onClick (E.input_ setAuth)] [H.text "Login"] ]


Add HTML property selectedIndex

Add HTML property selectedIndex

implement #520

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref
  , expand

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , download

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , selectedIndex
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

-- | Every `IProp lt i` can be cast to some `IProp gt i` as long as `lt` is a
-- | subset of `gt`.
expand ∷ ∀ lt gt a i. Row.Union lt a gt ⇒ IProp lt i → IProp gt i
expand = unsafeCoerce

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

download :: ∀ r i. String -> IProp (download :: String | r) i
download = prop (PropName "download")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

selectedIndex :: forall r i. Int -> IProp (selectedIndex :: Int | r) i
selectedIndex = prop (PropName "selectedIndex")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , attrNS
  , ref
  , expand

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , download

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , min
  , max
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , list
  , autofocus
  , multiple
  , pattern
  , accept

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputAcceptType (InputAcceptType(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName, Namespace, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.Input (Input(..), RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # Type) i = IProp (Prop (Input i))

derive instance newtypeIProp :: Newtype (IProp r i) _
derive instance functorIProp :: Functor (IProp r)

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (Input i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr =
  Core.attr Nothing #
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | Creates an indexed HTML attribute.
attrNS :: forall r i. Namespace -> AttrName -> String -> IProp r i
attrNS =
  pure >>> Core.attr >>>
    (unsafeCoerce
      :: (AttrName -> String -> Prop (Input i))
      -> AttrName
      -> String
      -> IProp r i)

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (Input i)) -> Prop (Input i)) -> (Maybe Element -> Maybe (Input i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (Input i)
  go p mel = Just (RefUpdate p mel)

-- | Every `IProp lt i` can be cast to some `IProp gt i` as long as `lt` is a
-- | subset of `gt`.
expand ∷ ∀ lt gt a i. Row.Union lt a gt ⇒ IProp lt i → IProp gt i
expand = unsafeCoerce

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

download :: ∀ r i. String -> IProp (download :: String | r) i
download = prop (PropName "download")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

min :: forall r i. Number -> IProp (min :: Number | r) i
min = prop (PropName "min")

max :: forall r i. Number -> IProp (max :: Number | r) i
max = prop (PropName "max")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

list :: forall r i. String -> IProp (list :: String | r) i
list = attr (AttrName "list")

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

accept :: forall r i. I.InputAcceptType -> IProp (accept :: I.InputAcceptType | r) i
accept = prop (PropName "accept")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")


[fe] link to homepage from Header

[fe] link to homepage from Header

module Component.Header where

import Core.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

renderForm :: forall p i. HH.HTML p i
renderForm =
  HH.form
  [ class_ "flex-1 ml-8"]
  [ HH.input
    [ class_ "border w-full py-2 px-2 focus:border-red500 outline-none"
    , HP.type_ HP.InputSearch
    , HP.name "q"
    , HP.placeholder "TED talk url or keywords"
    ]
  ]

render :: forall p i. HH.HTML p i
render =
  HH.div
  [ class_ "bg-white border-b border-grey300 py-4 shadow"]
  [ HH.div
    [ class_ "container flex items-center"]
    [ HH.a
      [ class_ "font-mono text-xl text-red500 no-underline"
      , HP.href "/"
      ]
      [ HH.text "∷ TED → [SRT]" ]
    , renderForm
    ]
  ]

module Component.Header where

import Core.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

renderForm :: forall p i. HH.HTML p i
renderForm =
  HH.form
  [ class_ "flex-1 ml-8"]
  [ HH.input
    [ class_ "border w-full py-2 px-2 focus:border-red500 outline-none"
    , HP.type_ HP.InputSearch
    , HP.name "q"
    , HP.placeholder "TED talk url or keywords"
    ]
  ]

render :: forall p i. HH.HTML p i
render =
  HH.div
  [ class_ "bg-white border-b border-grey300 py-4 shadow"]
  [ HH.div
    [ class_ "container flex items-center"]
    [ HH.span
      [ class_ "font-mono text-xl text-red500"]
      [ HH.text "∷ TED → [SRT]" ]
    , renderForm
    ]
  ]


Draw VScale + Track + Legend in UI demo

Draw VScale + Track + Legend in UI demo

module Genetics.Browser.Track.UI where

import Prelude

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

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

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

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

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

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

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

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

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

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BrowserPoint
  | Zoom (Ratio BigInt)
  | ScrollView (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             BrowserPoint
          -> Event UpdateView
btnScroll x = const (Scroll x) <$> buttonEvent "scrollLeft" <|>
              const (Scroll (negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (Zoom (m )) <$> buttonEvent "zoomOut" <|>
            const (Zoom (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BrowserPoint, zoom :: Ratio BigInt } -> Event UpdateView
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")

scrollView :: CoordSys ChrId BrowserPoint
           -> BrowserPoint
           -> BrowserView
           -> BrowserView
scrollView cs p v = (_ - p) <$> v

scrollViewGood :: Ratio BigInt
               -> BrowserView
               -> BrowserView
scrollViewGood rat iv = iv `shiftIntervalBy` rat

-- zoomView :: BrowserPoint
--          -> Ratio BigInt
--          -> BrowserView
--          -> BrowserView
-- zoomView (BPoint size) p iv@(Interval (BPoint l) (BPoint r)) =
--   let len = r - l
--       len' = (len * (Ratio.numerator p)) / (Ratio.denominator p)
--   in (Interval (BPoint $ max zero (l + len')) (BPoint $ min size (r - len')))

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Pair lhs rhs)
              (Pair l   r) = Pair (max lhs l) (min r rhs)

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
-- updateViewFold _ iv = iv
updateViewFold cs uv iv@(Pair l r) = case uv of
  Scroll p  -> scrollView cs p iv
  -- Zoom r    -> zoomView ssz.size r iv
  ScrollView x -> scrollViewGood x iv
  _ -> iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start

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

browserDrawEvent :: CoordSys ChrId BrowserPoint
                 -> { width :: Pixels, height :: Pixels }
                 -> { min :: Number, max :: Number, sig :: Number }
                 -- -> { vScaleWidth :: Pixels, legendWidth :: Pixels }
                 -> { gwas  :: Map ChrId (List _)
                    , annots :: Map ChrId (List _) }
                 -> Event BrowserView
                 -> Event Drawing
browserDrawEvent csys canvasSize vscale dat
  = let dd = demoBrowser csys canvasSize vscale {vScaleWidth, legendWidth} red demoLegend dat
        vScaleWidth = 40.0
        legendWidth = 100.0
    in map dd

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

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

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

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (CoordInterval _ _))
frameClick csys = map (findBrowserInterval csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = (map <<< map) f $ ev
  where f {chrSize, index} = Tuple index chrSize

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

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p = "Interval: " <> showView iv <> ";\t" <> show p

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

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                    p = x' % width
                in Debug.trace (show p) \_ -> p

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

main :: Eff _ _
main = launchAff do

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

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

  backCanvas <- liftEff $ newCanvas {w,h}

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

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = map negate $ browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BrowserPoint
      scroll = wrap $ BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      -- begin = Pair (wrap $ BigInt.fromInt 652428823) s.size
      begin = Pair zero s.size

      viewEvent :: Event _
      viewEvent = browserViewEvent cs begin
                    $ btnUpdateView {scroll, zoom} <|> dregs

      click :: Event Pixels
      click = clickEvent canvas

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

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

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

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

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

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

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

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

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

  let browserSize = {width: w, height: h}
      score = {min: 0.125, max: 0.42, sig: 0.25}

  let ev' = browserDrawEvent cs browserSize score dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

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

coordSys :: _
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

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

module Genetics.Browser.Track.UI where

import Prelude

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

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

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

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

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

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

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

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

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

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BrowserPoint
  | Zoom (Ratio BigInt)
  | ScrollView (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             BrowserPoint
          -> Event UpdateView
btnScroll x = const (Scroll x) <$> buttonEvent "scrollLeft" <|>
              const (Scroll (negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (Zoom (m )) <$> buttonEvent "zoomOut" <|>
            const (Zoom (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BrowserPoint, zoom :: Ratio BigInt } -> Event UpdateView
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")

scrollView :: CoordSys ChrId BrowserPoint
           -> BrowserPoint
           -> BrowserView
           -> BrowserView
scrollView cs p v = (_ - p) <$> v

scrollViewGood :: Ratio BigInt
               -> BrowserView
               -> BrowserView
scrollViewGood rat iv = iv `shiftIntervalBy` rat

-- zoomView :: BrowserPoint
--          -> Ratio BigInt
--          -> BrowserView
--          -> BrowserView
-- zoomView (BPoint size) p iv@(Interval (BPoint l) (BPoint r)) =
--   let len = r - l
--       len' = (len * (Ratio.numerator p)) / (Ratio.denominator p)
--   in (Interval (BPoint $ max zero (l + len')) (BPoint $ min size (r - len')))

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Pair lhs rhs)
              (Pair l   r) = Pair (max lhs l) (min r rhs)

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
-- updateViewFold _ iv = iv
updateViewFold cs uv iv@(Pair l r) = case uv of
  Scroll p  -> scrollView cs p iv
  -- Zoom r    -> zoomView ssz.size r iv
  ScrollView x -> scrollViewGood x iv
  _ -> iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start

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

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

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

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

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (CoordInterval _ _))
frameClick csys = map (findBrowserInterval csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = (map <<< map) f $ ev
  where f {chrSize, index} = Tuple index chrSize

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

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p = "Interval: " <> showView iv <> ";\t" <> show p

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

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                    p = x' % width
                in Debug.trace (show p) \_ -> p

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

main :: Eff _ _
main = launchAff do

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

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

  backCanvas <- liftEff $ newCanvas {w,h}

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

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = map negate $ browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BrowserPoint
      scroll = wrap $ BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      -- begin = Pair (wrap $ BigInt.fromInt 652428823) s.size
      begin = Pair zero s.size

      viewEvent :: Event _
      viewEvent = browserViewEvent cs begin
                    $ btnUpdateView {scroll, zoom} <|> dregs

      click :: Event Pixels
      click = clickEvent canvas

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

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

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

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

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

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

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

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

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

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

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

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

coordSys :: _
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

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


Remove testing socket

Remove testing socket

module Openspace.Ui.Stream where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Control.Alt
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Openspace.Ui.Engine
import Openspace.Ui.Localstorage
import Rx.Observable

uiStream :: forall eff. Eff ( dom :: DOM, console :: CONSOLE | eff ) (Observable UiAction)
uiStream = do
  observers <- getObservers
  let emitters = emitterLookup observers

      selectBlock = (uiActionFromForeign parseBlock SelectBlock) <<< getDetail
          <$> emitters "SelectBlock"

      unselectBlock = (const UnselectBlock) <$> emitters "UnselectBlock"

      chooseTopic = (uiActionFromForeign parseTopic ChooseTopic) <<< getDetail
          <$> emitters "ChooseTopic"

      unchooseTopic = (uiActionFromForeign parseTopic UnchooseTopic) <<< getDetail
          <$> (emitters "UnchooseTopic" <|> emitters "UnselectTopic")

  return $ selectBlock <|> unselectBlock <|> chooseTopic <|> unchooseTopic

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

main = do
  -- TODO: getSocket :: Either SockErr Socket
  socketUrl <- getSocketUrl
  -- let sockEmitter = getSocket ("ws://" ++ "frost.kritzcreek.me" ++ "/socket/0")
  let sockEmitter = getSocket ("ws://" ++ socketUrl)
  -- Initial State

  uiSt <- getTimetable "timetable" >>= newSTRef
  appSt <- newSTRef myState1
  -- Initial Render
  renderApp emptyState emptyUiState

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  --subscribe ui (\a -> emitAction sockEmitter (serialize a))
  -- Evaluate Action Observables
  subscribe net (\a -> do
                    appState <- modifySTRef appSt (evalAction a)
                    uiState <- modifySTRef uiSt (evalActionOnUi a)
                    setTimetable "timetable" uiState
                    renderApp appState uiState)
  subscribe ui (\a-> do
                   appState <- readSTRef appSt
                   uiState <- modifySTRef uiSt (evalUiAction a)
                   setTimetable "timetable" uiState
                   renderApp appState uiState)

module Openspace.Ui.Stream where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Control.Alt
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Openspace.Ui.Engine
import Openspace.Ui.Localstorage
import Rx.Observable

uiStream :: forall eff. Eff ( dom :: DOM, console :: CONSOLE | eff ) (Observable UiAction)
uiStream = do
  observers <- getObservers
  let emitters = emitterLookup observers

      selectBlock = (uiActionFromForeign parseBlock SelectBlock) <<< getDetail
          <$> emitters "SelectBlock"

      unselectBlock = (const UnselectBlock) <$> emitters "UnselectBlock"

      chooseTopic = (uiActionFromForeign parseTopic ChooseTopic) <<< getDetail
          <$> emitters "ChooseTopic"

      unchooseTopic = (uiActionFromForeign parseTopic UnchooseTopic) <<< getDetail
          <$> (emitters "UnchooseTopic" <|> emitters "UnselectTopic")

  return $ selectBlock <|> unselectBlock <|> chooseTopic <|> unchooseTopic

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

main = do
  -- TODO: getSocket :: Either SockErr Socket
  socketUrl <- getSocketUrl
  let sockEmitter = getSocket ("ws://" ++ "frost.kritzcreek.me" ++ "/socket/0")
  -- let sockEmitter = getSocket ("ws://" ++ socketUrl)
  -- Initial State

  uiSt <- getTimetable "timetable" >>= newSTRef
  appSt <- newSTRef myState1
  -- Initial Render
  renderApp emptyState emptyUiState

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  --subscribe ui (\a -> emitAction sockEmitter (serialize a))
  -- Evaluate Action Observables
  subscribe net (\a -> do
                    appState <- modifySTRef appSt (evalAction a)
                    uiState <- modifySTRef uiSt (evalActionOnUi a)
                    setTimetable "timetable" uiState
                    renderApp appState uiState)
  subscribe ui (\a-> do
                   appState <- readSTRef appSt
                   uiState <- modifySTRef uiSt (evalUiAction a)
                   setTimetable "timetable" uiState
                   renderApp appState uiState)


Use turn server as turn server!

Use turn server as turn server!

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "turn:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Add fix for memory leak due to variable capture

Fix proposed by @kirill-gavrilyuk here:
https://github.com/slamdata/purescript-halogen/issues/586#issuecomment-501677358

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

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, killFiber, launchAff_, runAff_, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, ComponentSlotBox, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ as HQ
import Halogen.Query.Input (Input)
import Halogen.Query.Input as Input

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
-- |
-- | The `dispose` function is called when the top level component is disposed of
-- | via `HalogenIO`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlotBox h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  , dispose :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  disposed <- liftEffect $ Ref.new false
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    dsx <- Ref.read =<< runComponent lchs (rootHandler listeners) i component
    unDriverStateX (\st ->
      pure
        { query: evalDriver disposed st.selfRef
        , subscribe: subscribe fresh listeners
        , dispose: dispose disposed lchs dsx listeners
        }) dsx

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref Boolean
    -> Ref (DriverState h r s f' act ps i' o')
    -> forall a. (f' a -> Aff (Maybe a))
  evalDriver disposed ref q =
    liftEffect (Ref.read disposed) >>=
      if _
        then pure Nothing
        else Eval.evalQ render ref q

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer $ either (const (Right unit)) Left <$> try (AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      -- The following 3 defs are working around a capture bug, see #586
      pendingHandlers = identity ds.pendingHandlers
      pendingQueries = identity ds.pendingQueries
      selfRef = identity ds.selfRef
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun pendingHandlers <<< void <<< Eval.evalF render selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun pendingQueries <<< handler <<< Input.Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlotBox h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            HQ.Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (HQ.Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptionsAndForks (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (HQ.Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

  dispose :: forall f' o'
     . Ref Boolean
    -> Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Ref (M.Map Int (AV.AVar o'))
    -> Aff Unit
  dispose disposed lchs dsx subsRef = Eval.handleLifecycle lchs do
    Ref.read disposed >>=
      if _
        then pure unit
        else do
          Ref.write true disposed
          traverse_ (launchAff_ <<< AV.kill (error "disposed")) =<< Ref.read subsRef
          finalize lchs dsx
          unDriverStateX (traverse_ renderSpec.dispose <<< _.rendering) dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptionsAndForks
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptionsAndForks (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions
  traverse_ (handleAff <<< killFiber (error "finalized")) =<< Ref.read ds.forks
  Ref.write M.empty ds.forks

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))

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

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, killFiber, launchAff_, runAff_, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, ComponentSlotBox, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ as HQ
import Halogen.Query.Input (Input)
import Halogen.Query.Input as Input

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
-- |
-- | The `dispose` function is called when the top level component is disposed of
-- | via `HalogenIO`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlotBox h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  , dispose :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  disposed <- liftEffect $ Ref.new false
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    dsx <- Ref.read =<< runComponent lchs (rootHandler listeners) i component
    unDriverStateX (\st ->
      pure
        { query: evalDriver disposed st.selfRef
        , subscribe: subscribe fresh listeners
        , dispose: dispose disposed lchs dsx listeners
        }) dsx

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref Boolean
    -> Ref (DriverState h r s f' act ps i' o')
    -> forall a. (f' a -> Aff (Maybe a))
  evalDriver disposed ref q =
    liftEffect (Ref.read disposed) >>=
      if _
        then pure Nothing
        else Eval.evalQ render ref q

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer $ either (const (Right unit)) Left <$> try (AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun ds.pendingHandlers <<< void <<< Eval.evalF render ds.selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun ds.pendingQueries <<< handler <<< Input.Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlotBox h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            HQ.Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (HQ.Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptionsAndForks (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (HQ.Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

  dispose :: forall f' o'
     . Ref Boolean
    -> Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Ref (M.Map Int (AV.AVar o'))
    -> Aff Unit
  dispose disposed lchs dsx subsRef = Eval.handleLifecycle lchs do
    Ref.read disposed >>=
      if _
        then pure unit
        else do
          Ref.write true disposed
          traverse_ (launchAff_ <<< AV.kill (error "disposed")) =<< Ref.read subsRef
          finalize lchs dsx
          unDriverStateX (traverse_ renderSpec.dispose <<< _.rendering) dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptionsAndForks
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptionsAndForks (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions
  traverse_ (handleAff <<< killFiber (error "finalized")) =<< Ref.read ds.forks
  Ref.write M.empty ds.forks

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))