progress on demo browser w/ layers

progress on demo browser w/ layers

module Genetics.Browser.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Monad.Aff (Aff, error, throwError)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, fold, foldMap, foldr, length, minimumBy, sequence_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Foreign (F, Foreign, ForeignError(..))
import Data.Foreign (readArray) as Foreign
import Data.Foreign.Index (readProp) as Foreign
import Data.Foreign.Keys (keys) as Foreign
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, 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(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Record.Builder (build, insert, modify)
import Data.Record.Extra (class Keys)
import Data.Record.Extra (keys) as Record
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Genetics.Browser (DrawingN, DrawingV, Feature, LegendConfig, LegendEntry, NPoint, OldRenderer, Peak, RenderedTrack, VScale, chrLabelsUI, defaultLegendConfig, defaultVScaleConfig, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, renderTrack, renderTrack', renderTrackLive, renderTrackLive', sigLevelRuler, trackLegend)
import Genetics.Browser.Bed (ParsedLine, chunkProducer, fetchBed)
import Genetics.Browser.Canvas (BrowserCanvas, BrowserContainer(..), Label, LabelPlace(LLeft, LCenter), LayerRenderable, UISlotGravity(UIRight, UILeft), _Dimensions, _Track, _drawings, getDimensions, uiSlots)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, Normalized(Normalized), _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerSlots)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj (SProxy :: SProxy "range") \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj (SProxy :: SProxy "single") { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj (SProxy :: SProxy "range") $ map f position

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: _, ps :: _, p_wald :: _, rs :: _ }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff _ (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get url

  rawSNPs <-
    case runExcept $ Foreign.readArray resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff _ (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get url

  rawAnnots <- case runExcept
                    $ Foreign.readArray resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEff do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEff do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type DemoLegendConfig =
  { radius    :: Number
  , outline   :: Color
  , snpColor  :: Color
  , geneColor :: Color }

defaultDemoLegend :: DemoLegendConfig
defaultDemoLegend =
  { radius:    5.5
  , outline:   black
  , snpColor:  blue
  , geneColor: red }

annotationLegendEntry :: ∀ r. DemoLegendConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor conf.outline <> lineWidth 2.0)
                  <> filled (fillColor color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => DemoLegendConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored vs s =
    { x: featureNormX s
    , y: wrap $ normYLogScore vs s.feature.score
    }

normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: VScale
       -> UISlotGravity
       -> BrowserCanvas
       -> Drawing
snpsUI vscale = renderFixedUI (drawVScaleInSlot vscale)

annotationsUI :: ∀ r.
                 LegendConfig r
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
annotationsUI legend = renderFixedUI (drawLegendInSlot legend)

type SNPConfig r
  = ( radius :: Number
    , color :: { outline :: Color
               , fill    :: Color }
    , pixelOffset :: Point
    | r )

defaultSNPConfig :: { | SNPConfig () }
defaultSNPConfig =
  { radius: 3.75
  , color: { outline: darkblue, fill: darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ m r1 r2.
              { threshold  :: { min  :: Number, max :: Number | r1 }
              , snpsConfig :: { | SNPConfig () } | r2 }
           -> Canvas.Dimensions
           -> Map ChrId (Array (SNP ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (SNP ())
renderSNPs { snpsConfig, threshold } cdim snpData =
  let features :: Array (SNP ())
      features = fold snpData

      snps = snpsConfig
      radius = snps.radius

      drawing =
          let {x,y} = snps.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor snps.color.outline) c
              fill  = filled   (fillColor    snps.color.fill)    c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (SNP ()) NPoint))
      npointed = (map <<< map)
        (fanout id (\s ->
           { x: featureNormX s
           , y: wrap $ normYLogScore threshold s.feature.score })) snpData

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed = foldMapWithIndex scaleSegs
        where rescale seg@(Pair offset _) npoint =
                  { x: offset + (pairSize seg) * (unwrap npoint.x)
                  , y: cdim.height * (one - unwrap npoint.y) }

              scaleSegs chrId seg = foldMap (map <<< map $ rescale seg)
                                      $ Map.lookup chrId npointed

      overlaps :: Array (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderSNPs' :: ∀ m r1 r2 r3.
              { threshold  :: { min  :: Number, max :: Number | r1 }
              , snpsConfig :: { | SNPConfig () } | r2 }
           -- -> Canvas.Dimensions
           -> Map ChrId (Array (SNP ()))
           -> Map ChrId (Pair Number)
           -> Canvas.Dimensions
           -> LayerRenderable
renderSNPs' { snpsConfig, threshold } snpData =
  let features :: Array (SNP ())
      features = fold snpData

      snps = snpsConfig
      radius = snps.radius

      drawing =
          let {x,y} = snps.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor snps.color.outline) c
              fill  = filled   (fillColor    snps.color.fill)    c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (SNP ()) NPoint))
      npointed = (map <<< map)
        (fanout id (\s ->
           { x: featureNormX s
           , y: wrap $ normYLogScore threshold s.feature.score })) snpData

      pointed :: _
              -> Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed size = foldMapWithIndex scaleSegs
        where rescale seg@(Pair offset _) npoint =
                  { x: offset + (pairSize seg) * (unwrap npoint.x)
                  , y: size.height * (one - unwrap npoint.y) }

              scaleSegs chrId seg = foldMap (map <<< map $ rescale seg)
                                      $ Map.lookup chrId npointed

      overlaps :: Array (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg size ->
        let pts = pointed size seg
        in inj _drawings $ drawings pts
        -- in { features
        --    , drawings: drawings pts
        --    , labels: mempty
        --    , overlaps: overlaps pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> DemoLegendConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawings :: _, labels :: _ }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f :: ChrId -> Array (Peak _ _ _) -> Array (Peak _ _ (Annotation r2))
              f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x,y,w,h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array DrawingN) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array DrawingN) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawings labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawings, labels }

renderAnnotation :: ∀ r r1 r2.
                    CoordSys _ _
                 -> Map ChrId (Array (SNP ()))
                 -> { min :: Number, max :: Number | r }
                 -> DemoLegendConfig
                 -> Canvas.Dimensions
                 -> Map ChrId (Array (Annotation r2))
                 -> Map ChrId (Pair Number)
                 -> RenderedTrack (Annotation r2)
renderAnnotation cSys sigSnps vScale conf cdim allAnnots =
  let features = fold allAnnots
      annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \segs -> let {drawings, labels} =
                    renderAnnotationPeaks cSys vScale conf (annoPeaks segs) cdim segs
              in { features, overlaps: mempty
                 , drawings, labels }

demoBrowser :: ∀ r r2.
               CoordSys ChrId BigInt
            -> { score :: { min :: Number, max :: Number, sig :: Number } | r }
            -> { snps        :: Map ChrId (Array _)
               , annotations :: Map ChrId (Array _) | r2 }
            -> BrowserCanvas
            -> CoordSysView
            -> { tracks     :: { snps        :: RenderedTrack (SNP _)
                               , annotations :: RenderedTrack (Annotation _) }
               , relativeUI :: Drawing
               , fixedUI    :: Drawing }
demoBrowser cSys config trackData =
  let
      threshold = config.score
      vscale = defaultVScaleConfig threshold

      sigSnps = filterSig config.score trackData.snps
      legend = defaultLegendConfig
               $ (annotationLegendTest defaultDemoLegend)
                  trackData.annotations

      conf = { segmentPadding: 12.0 }

      snps =
        renderTrack conf cSys (renderSNPs {threshold, snpsConfig: defaultSNPConfig}) trackData.snps

      annotations =
        renderTrack conf cSys (renderAnnotation cSys sigSnps vscale defaultDemoLegend) trackData.annotations

      relativeUI = chrLabelsUI cSys {fontSize: 12}

  in \bc v ->
    let trackDim = bc ^. _Track <<< _Dimensions
        slots = uiSlots bc
        fixedUI =  (snpsUI        vscale UILeft  bc)
                <> (annotationsUI legend UIRight bc)
                <> (Drawing.translate slots.left.size.width slots.top.size.height
                    $ sigLevelRuler vscale red trackDim)

    in { tracks: { snps: snps bc v
                 , annotations: annotations bc v }
       , relativeUI: relativeUI bc v
       , fixedUI }

type BrowserConfig =
  { chrLabelsUI :: { fontSize :: Int }
  , legend :: DemoLegendConfig
  -- , vscale :: VScale
  , threshold :: { min :: Number, max :: Number, sig :: Number }
  , snpsConfig :: { | SNPConfig () }
  }

demoBrowser' :: ∀ r r2.
                CoordSys ChrId BigInt
             -> { score :: { min :: Number, max :: Number, sig :: Number } | r }
             -> { snps        :: Map ChrId (Array _)
                , annotations :: Map ChrId (Array _) | r2 }
             -> BrowserContainer
             -> CoordSysView
             -> Eff _ (List (Layer (ComponentSlot -> LayerRenderable)))
demoBrowser' cSys config trackData =
  let threshold = config.score
      vscale = defaultVScaleConfig threshold

      sigSnps = filterSig config.score trackData.snps
      legend = defaultLegendConfig
               $ (annotationLegendTest defaultDemoLegend)
                  trackData.annotations

      conf = { segmentPadding: 12.0 }

      snps :: ∀ r3.
              { size :: Canvas.Dimensions | r3 }
           -> CoordSysView
           -> Layer (Canvas.Dimensions -> LayerRenderable)
      snps slot v =
        renderTrack' conf cSys
          (Full $ renderSNPs' {threshold, snpsConfig: defaultSNPConfig})
          trackData.snps slot.size v

      -- annotations =
      --   renderTrack conf cSys (renderAnnotation cSys sigSnps vscale defaultDemoLegend) trackData.annotations

      -- relativeUI = chrLabelsUI cSys {fontSize: 12}

  in \bc v -> do
    dims <- getDimensions bc
    pure mempty

        -- trackDim = bc ^. _Track <<< _Dimensions
        -- slots = uiSlots bc
        -- fixedUI =  (snpsUI        vscale UILeft  bc)
        --         <> (annotationsUI legend UIRight bc)
        --         <> (Drawing.translate slots.left.size.width slots.top.size.height
        --             $ sigLevelRuler vscale red trackDim)

    -- in { tracks: { snps: snps bc v
    --              , annotations: annotations bc v }
    --    , relativeUI: relativeUI bc v
    --    , fixedUI }

module Genetics.Browser.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Monad.Aff (Aff, error, throwError)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, fold, foldMap, foldr, length, minimumBy, sequence_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Foreign (F, Foreign, ForeignError(..))
import Data.Foreign (readArray) as Foreign
import Data.Foreign.Index (readProp) as Foreign
import Data.Foreign.Keys (keys) as Foreign
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, 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(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Record.Builder (build, insert, modify)
import Data.Record.Extra (class Keys)
import Data.Record.Extra (keys) as Record
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Genetics.Browser (DrawingN, DrawingV, Feature, LegendConfig, LegendEntry, NPoint, OldRenderer, Peak, RenderedTrack, VScale, chrLabelsUI, defaultLegendConfig, defaultVScaleConfig, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, renderTrack, renderTrackLive, renderTrackLive', sigLevelRuler, trackLegend)
import Genetics.Browser.Bed (ParsedLine, chunkProducer, fetchBed)
import Genetics.Browser.Canvas (BrowserCanvas, Label, LabelPlace(LLeft, LCenter), UISlotGravity(UIRight, UILeft), _Dimensions, _Track, uiSlots)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, Normalized(Normalized), _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj (SProxy :: SProxy "range") \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj (SProxy :: SProxy "single") { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj (SProxy :: SProxy "range") $ map f position

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: _, ps :: _, p_wald :: _, rs :: _ }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff _ (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get url

  rawSNPs <-
    case runExcept $ Foreign.readArray resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff _ (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get url

  rawAnnots <- case runExcept
                    $ Foreign.readArray resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEff do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEff do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type DemoLegendConfig =
  { radius    :: Number
  , outline   :: Color
  , snpColor  :: Color
  , geneColor :: Color }

defaultDemoLegend :: DemoLegendConfig
defaultDemoLegend =
  { radius:    5.5
  , outline:   black
  , snpColor:  blue
  , geneColor: red }

annotationLegendEntry :: ∀ r. DemoLegendConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor conf.outline <> lineWidth 2.0)
                  <> filled (fillColor color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => DemoLegendConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored vs s =
    { x: featureNormX s
    , y: wrap $ normYLogScore vs s.feature.score
    }

normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: VScale
       -> UISlotGravity
       -> BrowserCanvas
       -> Drawing
snpsUI vscale = renderFixedUI (drawVScaleInSlot vscale)

annotationsUI :: ∀ r.
                 LegendConfig r
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
annotationsUI legend = renderFixedUI (drawLegendInSlot legend)

type SNPConfig r
  = ( radius :: Number
    , color :: { outline :: Color
               , fill    :: Color }
    , pixelOffset :: Point
    | r )

defaultSNPConfig :: { | SNPConfig () }
defaultSNPConfig =
  { radius: 3.75
  , color: { outline: darkblue, fill: darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ m r1 r2.
              { threshold  :: { min  :: Number, max :: Number | r1 }
              , snpsConfig :: { | SNPConfig () } | r2 }
           -> Canvas.Dimensions
           -> Map ChrId (Array (SNP ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (SNP ())
renderSNPs { snpsConfig, threshold } cdim snpData =
  let features :: Array (SNP ())
      features = fold snpData

      snps = snpsConfig
      radius = snps.radius

      drawing =
          let {x,y} = snps.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor snps.color.outline) c
              fill  = filled   (fillColor    snps.color.fill)    c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (SNP ()) NPoint))
      npointed = (map <<< map)
        (fanout id (\s ->
           { x: featureNormX s
           , y: wrap $ normYLogScore threshold s.feature.score })) snpData

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed = foldMapWithIndex scaleSegs
        where rescale seg@(Pair offset _) npoint =
                  { x: offset + (pairSize seg) * (unwrap npoint.x)
                  , y: cdim.height * (one - unwrap npoint.y) }

              scaleSegs chrId seg = foldMap (map <<< map $ rescale seg)
                                      $ Map.lookup chrId npointed

      overlaps :: Array (Tuple (SNP ()) Point)
               -> Number -> Point
               -> Array (SNP ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (SNP ()) Point -> Maybe (SNP ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> DemoLegendConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawings :: _, labels :: _ }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f :: ChrId -> Array (Peak _ _ _) -> Array (Peak _ _ (Annotation r2))
              f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x,y,w,h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array DrawingN) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array DrawingN) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawings labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawings, labels }

renderAnnotation :: ∀ r r1 r2.
                    CoordSys _ _
                 -> Map ChrId (Array (SNP ()))
                 -> { min :: Number, max :: Number | r }
                 -> DemoLegendConfig
                 -> Canvas.Dimensions
                 -> Map ChrId (Array (Annotation r2))
                 -> Map ChrId (Pair Number)
                 -> RenderedTrack (Annotation r2)
renderAnnotation cSys sigSnps vScale conf cdim allAnnots =
  let features = fold allAnnots
      annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \segs -> let {drawings, labels} =
                    renderAnnotationPeaks cSys vScale conf (annoPeaks segs) cdim segs
              in { features, overlaps: mempty
                 , drawings, labels }

demoBrowser :: ∀ r r2.
               CoordSys ChrId BigInt
            -> { score :: { min :: Number, max :: Number, sig :: Number } | r }
            -> { snps        :: Map ChrId (Array _)
               , annotations :: Map ChrId (Array _) | r2 }
            -> BrowserCanvas
            -> CoordSysView
            -> { tracks     :: { snps        :: RenderedTrack (SNP _)
                               , annotations :: RenderedTrack (Annotation _) }
               , relativeUI :: Drawing
               , fixedUI    :: Drawing }
demoBrowser cSys config trackData =
  let
      threshold = config.score
      vscale = defaultVScaleConfig threshold

      sigSnps = filterSig config.score trackData.snps
      legend = defaultLegendConfig
               $ (annotationLegendTest defaultDemoLegend)
                  trackData.annotations

      conf = { segmentPadding: 12.0 }

      snps =
        renderTrack conf cSys (renderSNPs {threshold, snpsConfig: defaultSNPConfig}) trackData.snps

      annotations =
        renderTrack conf cSys (renderAnnotation cSys sigSnps vscale defaultDemoLegend) trackData.annotations

      relativeUI = chrLabelsUI cSys {fontSize: 12}

  in \bc v ->
    let trackDim = bc ^. _Track <<< _Dimensions
        slots = uiSlots bc
        fixedUI =  (snpsUI        vscale UILeft  bc)
                <> (annotationsUI legend UIRight bc)
                <> (Drawing.translate slots.left.size.width slots.top.size.height
                    $ sigLevelRuler vscale red trackDim)

    in { tracks: { snps: snps bc v
                 , annotations: annotations bc v }
       , relativeUI: relativeUI bc v
       , fixedUI }

type BrowserConfig =
  { chrLabelsUI :: { fontSize :: Int }
  , legend :: DemoLegendConfig
  -- , vscale :: VScale
  , threshold :: { min :: Number, max :: Number, sig :: Number }
  , snpsConfig :: { | SNPConfig () }
  }


Main.purs: update to latest thermite

Main.purs: update to latest thermite

module Main where

import Prelude
import Control.Monad.Eff
import Data.Maybe
import Data.Nullable

import qualified Thermite as T
import qualified Thermite.Action as T
import qualified React as R
import qualified React.DOM as R
import qualified React.DOM.Props as RP

import qualified DOM as DOM
import qualified DOM.HTML as DOM
import qualified DOM.HTML.Document as DOM
import qualified DOM.HTML.Types as DOM
import qualified DOM.HTML.Window as DOM
import qualified DOM.Node.Types as DOM

import Control.Monad.Eff.Console

data Action = Increment | Decrement
type State = { counter :: Int }

initialState :: State
initialState = { counter: 0 }

render :: T.Render _ State _ Action
render send s _ _ = R.div' [ counter, buttons ]
  where
  counter :: R.ReactElement
  counter =
    R.p'
      [ R.text "Value: "
      , R.text $ show s.counter
      ]

  buttons :: R.ReactElement
  buttons =
    R.p'
      [ R.button [ RP.onClick \_ -> send Increment ]
                 [ R.text "Increment" ]
      , R.button [ RP.onClick \_ -> send Decrement ]
                 [ R.text "Decrement" ]
      ]

performAction _ Increment = T.modifyState \o -> { counter: o.counter + 1 }
performAction _ Decrement = T.modifyState \o -> { counter: o.counter - 1 }

spec :: T.Spec _ State _ Action
spec =
  T.simpleSpec initialState performAction render

main = do
  print "Hello sailor!"
  body' <- body
  case R.render (R.createFactory (T.createClass spec) {}) <$> body' of
    Nothing -> print "nothing :("
    Just something -> void something

  where
  body :: forall eff. Eff (dom :: DOM.DOM | eff) (Maybe DOM.Element)
  body = do
    win <- DOM.window
    doc <- DOM.document win
    elm <- toMaybe <$> DOM.body doc
    return (DOM.htmlElementToElement <$> elm)

module Main where

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T
import qualified Thermite.Events as T
import qualified Thermite.Types as T

import Debug.Trace

data Action = Increment | Decrement
type State = { counter :: Number }

initialState :: State
initialState = { counter: 0 }

render :: T.Render _ State _ Action
render context state _ _ =
  T.div' [counter, buttons]
  where
    counter :: T.Html _
    counter =
      T.p' [ T.text "Value: "
           , T.text (show state.counter)
           ]

    buttons :: T.Html _
    buttons = T.p' [ T.button (T.onClick context (const Increment)) [T.text "Increment"]
                   , T.button (T.onClick context (const Decrement)) [T.text "Decrement"]
                   ]

performAction :: T.PerformAction _ State _ Action
performAction _ Increment = T.modifyState \o -> { counter: o.counter + 1 }
performAction _ Decrement = T.modifyState \o -> { counter: o.counter - 1 }

spec :: T.Spec _ State _ Action
spec =
  T.simpleSpec initialState performAction render

main = do
  trace "Hello sailor!"
  T.render (T.createClass spec) {}


remove unused imports

remove unused imports

module Test.Main where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Argonaut.Core
import Data.Argonaut.Combinators

import Test.Spec
import Test.Spec.Assertions
import Test.Spec.Reporter.Console
import Test.Spec.Runner

import Electron
import Electron.BrowserWindow
import Electron.Options

main :: forall eff. Eff (console :: CONSOLE, process :: Process, electron :: ELECTRON | eff) Unit
main = run [consoleReporter] do
  describe "encodeOptions :: BrowserWindowOptions -> Json" do
    it "can encode all options" do
      let options = [Width 640, Height 480, WebPreferences [OverlayScrollbars true]]
      encodeOptions options `shouldEqual` (  "width"  := 640
                                          ~> "height" := 480
                                          ~> "webPreferences" := ( "overlayScrollbars" := true
                                                                 ~> jsonEmptyObject )
                                          ~> jsonEmptyObject )

module Test.Main where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Aff

import Data.Argonaut.Core
import Data.Argonaut.Combinators

import Test.Spec
import Test.Spec.Assertions
import Test.Spec.Reporter.Console
import Test.Spec.Runner

import Electron
import Electron.BrowserWindow
import Electron.Options
import Electron.Shell

main :: forall eff. Eff (console :: CONSOLE, process :: Process, electron :: ELECTRON | eff) Unit
main = run [consoleReporter] do
  describe "encodeOptions :: BrowserWindowOptions -> Json" do
    it "can encode all options" do
      let options = [Width 640, Height 480, WebPreferences [OverlayScrollbars true]]
      encodeOptions options `shouldEqual` (  "width"  := 640
                                          ~> "height" := 480
                                          ~> "webPreferences" := ( "overlayScrollbars" := true
                                                                 ~> jsonEmptyObject )
                                          ~> jsonEmptyObject )


fix typos.

fix typos.

module Openspace.Types where

import Data.Tuple
import Data.Maybe
import qualified Data.Map as M
import Data.Either
import Data.Foreign
import Data.Foreign.Class

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
-- TODO: Find a proper way to enumerate Union Datatypes
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String, typ :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) (Topic t1) (Topic t2) = t1.description /= t2.description || t1.typ /= t2.typ

instance foreignTopic :: IsForeign Topic where
    read val = do
      description <- readProp "description" val :: F String
      typ         <- readProp "typ"         val :: F TopicType
      return $ Topic {description: description, typ: typ}

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) = (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = do
    room <- readProp "room" val :: F Room
    block <- readProp "block" val :: F Block
    return $ Slot {room: room, block: block}

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = do
    name     <- readProp "name" val     :: F String
    capacity <- readProp "capacity" val :: F Number
    return $ Room {name: name, capacity: capacity}

-------------
--| Block |--
-------------

newtype Block = Block { start :: String }
instance showBlock :: Show Block where
  show (Block b) = b.start
instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.start == b2.start
  (/=) (Block b1) (Block b2) = b1.start /= b2.start
instance foreignBlock :: IsForeign Block where
  read val = do
    start <- readProp "start" val     :: F String
    return $ Block {start: start}

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "action" val of
  Right "AddTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ AddTopic t
  Right "DeleteTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ DeleteTopic t
  Right "AddRoom" -> do
    r <- readProp "room" val :: F Room
    return $ AddRoom r
  Right "DeleteRoom" -> do
    r <- readProp "room" val :: F Room
    return $ DeleteRoom r
  Right "AddBlock" -> do
    b <- readProp "block" val :: F Block
    return $ AddBlock b
  Right "DeleteBlock" -> do
    b <- readProp "block" val :: F Block
    return $ DeleteBlock b
  Right "AssignTopic" -> do
    s <- readProp "slot" val :: F Slot
    t <- readProp "topic" val :: F Topic
    return $ AssignTopic s t
  Right "UnassignTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ UnassignTopic t
  Right "ShowError" -> do
    m <- readProp "message" val :: F String
    return $ ShowError m
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) = toForeign { action: "AddTopic"
                                             , topic: { description: t.description
                                                      , typ: show t.typ
                                                      }
                                             }

  serialize (DeleteTopic (Topic t)) = toForeign { action: "DeleteTopic"
                                                , topic: { description: t.description
                                                         , typ: show t.typ
                                                         }
                                                }
  serialize (AddRoom (Room r)) = toForeign { action: "AddRoom"
                                           , room: r }

  serialize (DeleteRoom (Room r)) = toForeign { action: "DeleteRoom"
                                              , room: r }

  serialize (AddBlock (Block b)) = toForeign { action: "AddBlock"
                                             , block: b }

  serialize (DeleteBlock (Block b)) = toForeign { action: "DeleteBlock"
                                                , block: b }

  serialize (AssignTopic s (Topic t)) = toForeign { action: "AssignTopic"
                                                        , topic: { description: t.description
                                                                 , typ: show t.typ
                                                                 }
                                                        , slot: s
                                                        }

  serialize (UnassignTopic (Topic t)) = toForeign { action: "UnassignTopic"
                                                  , topic: { description: t.description
                                                           , typ: show t.typ
                                                           }
                                                  }

  serialize (ShowError s) = toForeign { action: "ShowError"
                                      , message: s
                                      }
-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , slots :: [Slot]
                , timeslots :: M.Map Slot Topic
                }

type SanitizedTopic = { description :: String, typ :: String }
type SanitizedSlot =  { room :: String, block :: String }
type SanitizedTimeslot = Tuple SanitizedSlot SanitizedTopic

type SanitizedAppState = { topics :: [SanitizedTopic]
                         , rooms :: [Room]
                         , blocks :: [Block]
                         , slots :: [SanitizedSlot]
                         , timeslots :: [SanitizedTimeslot]
                         }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], slots: [], timeslots: []}

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Köln", capacity: 30}

myBlock = Block {start: "8:00am"}
myBlock1 = Block {start: "12:00am"}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , slots : [mySlot, mySlot1]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }

module Openspace.Types where

import Data.Tuple
import Data.Maybe
import qualified Data.Map as M
import Data.Either
import Data.Foreign
import Data.Foreign.Class

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
-- TODO: Find a proper way to enumerate Union Datatypes
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String, typ :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) (Topic t1) (Topic t2) = t1.description /= t2.description || t1.typ /= t2.typ

instance foreignTopic :: IsForeign Topic where
    read val = do
      description <- readProp "description" val :: F String
      typ         <- readProp "typ"         val :: F TopicType
      return $ Topic {description: description, typ: typ}

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) = (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = do
    room <- readProp "room" val :: F Room
    block <- readProp "block" val :: F Block
    return $ Slot {room: room, block: block}

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = do
    name     <- readProp "name" val     :: F String
    capacity <- readProp "capacity" val :: F Number
    return $ Room {name: name, capacity: capacity}

-------------
--| Block |--
-------------

newtype Block = Block { start :: String }
instance showBlock :: Show Block where
  show (Block b) = b.start
instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.start == b2.start
  (/=) (Block b1) (Block b2) = b1.start /= b2.start
instance foreignBlock :: IsForeign Block where
  read val = do
    start <- readProp "start" val     :: F String
    return $ Block {start: start}

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "action" val of
  Right "AddTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ AddTopic t
  Right "DeleteTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ DeleteTopic t
  Right "AddRoom" -> do
    r <- readProp "room" val :: F Room
    return $ AddRoom r
  Right "DeleteRoom" -> do
    r <- readProp "room" val :: F Room
    return $ DeleteRoom r
  Right "AddBlock" -> do
    b <- readProp "block" val :: F Block
    return $ AddBlock b
  Right "DeleteBlock" -> do
    b <- readProp "block" val :: F Block
    return $ DeleteBlock b
  Right "AssignTopic" -> do
    s <- readProp "slot" val :: F Slot
    t <- readProp "topic" val :: F Topic
    return $ AssignTopic s t
  Right "UnassignTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ UnassignTopic t
  Right "ShowError" -> do
    m <- readProp "message" val :: F String
    return $ ShowError m
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) = toForeign { action: "AddTopic"
                                             , topic: { description: t.description
                                                      , typ: show t.typ
                                                      }
                                             }

  serialize (DeleteTopic (Topic t)) = toForeign { action: "DeleteTopic"
                                                , topic: { description: t.description
                                                         , typ: show t.typ
                                                         }
                                                }
  serialize (AddRoom (Room r)) = toForeign { action: "AddRoom"
                                           , room: r }

  serialize (DeleteRoom (Room r)) = toForeign { action: "DeleteRoom"
                                              , room: r }

  serialize (AddBlock (Block b)) = toForeign { action: "AddBlock"
                                             , room: b }

  serialize (DeleteBlock (Block b)) = toForeign { action: "DeleteBlock"
                                                , room: b }

  serialize (AssignTopic s (Topic t)) = toForeign { action: "AssignTopic"
                                                        , topic: { description: t.description
                                                                 , typ: show t.typ
                                                                 }
                                                        , slot: s
                                                        }

  serialize (UnassignTopic (Topic t)) = toForeign { action: "UnassignTopic"
                                                  , topic: { description: t.description
                                                           , typ: show t.typ
                                                           }
                                                  }

  serialize (ShowError s) = toForeign { action: "ShowError"
                                      , message: s
                                      }
-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , slots :: [Slot]
                , timeslots :: M.Map Slot Topic
                }

type SanitizedTopic = { description :: String, typ :: String }
type SanitizedSlot =  { room :: String, block :: String }
type SanitizedTimeslot = Tuple SanitizedSlot SanitizedTopic

type SanitizedAppState = { topics :: [SanitizedTopic]
                         , rooms :: [Room]
                         , blocks :: [Block]
                         , slots :: [SanitizedSlot]
                         , timeslots :: [SanitizedTimeslot]
                         }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], slots: [], timeslots: []}

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Köln", capacity: 30}

myBlock = Block {start: "8:00am"}
myBlock1 = Block {start: "12:00am"}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , slots : [mySlot, mySlot1]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }


formatted

formatted

module Blueprint.Components.EditableText where

import Prelude

import Blueprint.ComponentsClasses (editableTextClass)
import Blueprint.PropTypes (Intent, Prop, UnknownEventType)
import React (ReactElement, createElement)

type EditableTextProps =
  { className :: String
  , intent :: Intent
  , confirmOnEnterKey :: Boolean
  , defaultValue :: String
  , disabled :: Boolean
  , isEditing :: Boolean
  , maxLength :: Int
  , minWidth :: Int
  , multiline :: Boolean
  , maxLines :: Int
  , minLines :: Int
  , placeholder :: String
  , selectAllOnFocus :: Boolean
  , value :: String
  , onCancel :: String -> Unit
  , onChange :: String -> Unit
  , onConfirm :: String -> Unit
  , onEdit :: UnknownEventType
  }

editableText :: Prop EditableTextProps -> ReactElement
editableText p = createElement editableTextClass p []

module Blueprint.Components.EditableText where

import Prelude
import Blueprint.PropTypes (Intent, Prop, UnknownEventType)
import Blueprint.ComponentsClasses (editableTextClass)
import React (ReactElement, createElement)

type IEditableTextProps = { className :: String
                          , intent :: Intent
                          , confirmOnEnterKey :: Boolean
                          , defaultValue :: String
                          , disabled :: Boolean
                          , isEditing :: Boolean
                          , maxLength :: Int
                          , minWidth  :: Int
                          , multiline :: Boolean
                          , maxLines  :: Int
                          , minLines  :: Int
                          , placeholder :: String
                          , selectAllOnFocus :: Boolean
                          , value :: String
                          , onCancel :: String -> Unit
                          , onChange :: String -> Unit
                          , onConfirm :: String -> Unit
                          , onEdit :: UnknownEventType
                          }

editableText :: Prop IEditableTextProps -> ReactElement
editableText p = createElement editableTextClass p []


Add notice of SProxy deprecation

Add notice of SProxy deprecation

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
-- | **Deprecated as of v0.14.0 PureScript release**: use `Type.Proxy` instead.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  reflectSymbol :: forall proxy. proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  reflectSymbol :: forall proxy. proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce


use operator in default sample

use operator in default sample

module DefaultText where

defaultSrc = """
clear = FrameBuffer $ (DepthImage @1 1000, ColorImage @1 navy)   -- ...

triangleRasterCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex
colorFragmentCtx = AccumulationContext (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

rasterizeWith = Rasterize
triangles = triangleRasterCtx

cubeVertexStream = Fetch "stream4" Triangles (Attribute "position4" :: Vec 4 Float)
mapFragments s fs = Accumulate colorFragmentCtx PassAll (\a -> FragmentOutRastDepth $ fs a) s clear
transform s f =  Transform (\v -> VertexOut (f v) 1 () (Smooth v)) s

rotate' v = (Uniform "MVP" :: Mat 4 4 Float) *. v

main =             cubeVertexStream         -- cube vertices
    `transform`    (scale 0.5 . rotate')    -- scale them
     &             rasterizeWith triangles  -- rasterize
    `mapFragments` id
     &             ScreenOut                --  draw into screen
"""

module DefaultText where

defaultSrc = """
clear = FrameBuffer $ (DepthImage @1 1000, ColorImage @1 navy)   -- ...

triangleRasterCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex
colorFragmentCtx = AccumulationContext (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

rasterizeWith = Rasterize
triangles = triangleRasterCtx

cubeVertexStream = Fetch "stream4" Triangles (Attribute "position4" :: Vec 4 Float)
mapFragments s fs = Accumulate colorFragmentCtx PassAll (\a -> FragmentOutRastDepth $ fs a) s clear
transform s f =  Transform (\v -> VertexOut (f v) 1 () (Smooth v)) s

rotate' v = (Uniform "MVP" :: Mat 4 4 Float) `PrimMulMatVec` v

main =             cubeVertexStream         -- cube vertices
    `transform`    (scale 0.5 . rotate')    -- scale them
     &             rasterizeWith triangles  -- rasterize
    `mapFragments` id
     &             ScreenOut                --  draw into screen
"""


fix explorer test (#4208)

fix explorer test (#4208)

fix explorer test

-- | Helper functions to mock data.
-- |
-- | _Note_: All these functions are used for testing only.

module Explorer.Test.MockFactory where

import Prelude

import Data.Array ((..))
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Data.Time.NominalDiffTime (NominalDiffTime, mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Types.State (CTxBriefs)
import Explorer.Util.Factory (mkCAddress, mkCHash, mkCTxId, mkCoin)
import Pos.Explorer.Web.ClientTypes (CAddress, CAddressSummary(..), CAddressType(..), CBlockEntry(..), CCoin, CGenesisAddressInfo(..), CGenesisSummary(..), CHash, CTxBrief(..), CTxEntry(..), CTxId)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, _CBlockEntry, _CTxEntry, caTxList, cbeBlkHash, cbeEpoch, cbeSlot, cbeTimeIssued, cteId, cteTimeIssued)

-- | Creates a `CTxEntry` with "empty" data
mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: Just $ mkTime 0.0
    , cteAmount: mkCoin "0"
    }

-- | Update hash of a transcation
setIdOfTx :: CTxId -> CTxEntry -> CTxEntry
setIdOfTx txId tx =
    set (_CTxEntry <<< cteId) txId tx

-- | Update time of a transaction
setTimeOfTx :: NominalDiffTime -> CTxEntry -> CTxEntry
setTimeOfTx time tx =
    set (_CTxEntry <<< cteTimeIssued) (Just time) tx

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caType: CUnknownAddress
    , caTxNum: 0
    , caBalance: mkCoin "0"
    , caTxList: []
    }

-- | Update txs of a `CAddressSummary`
setTxOfAddressSummary :: CTxBriefs -> CAddressSummary -> CAddressSummary
setTxOfAddressSummary txs addr =
    set (_CAddressSummary <<< caTxList) txs addr

mkCBlockEntry :: CBlockEntry
mkCBlockEntry = CBlockEntry
    { cbeEpoch: 0
    , cbeSlot: 0
    , cbeBlkHash: mkCHash "0"
    , cbeBlkHeight: 0
    , cbeTimeIssued: Nothing
    , cbeTxNum: 0
    , cbeTotalSent: mkCoin "0"
    , cbeFees: mkCoin "0"
    , cbeSize: 0
    , cbeBlockLead: Nothing
    }

-- | Update time of a slot
setTimeOfBlock :: NominalDiffTime -> CBlockEntry -> CBlockEntry
setTimeOfBlock time block =
    set (_CBlockEntry <<< cbeTimeIssued) (Just time) block

-- | Update slot / epoch of a slot
setEpochSlotOfBlock :: Int -> Int -> CBlockEntry -> CBlockEntry
setEpochSlotOfBlock epoch slot block =
    let block' = setEpochOfBlock epoch block in
    set (_CBlockEntry <<< cbeSlot) slot block'

-- | Update epoch of a slot
setEpochOfBlock :: Int -> CBlockEntry -> CBlockEntry
setEpochOfBlock epoch block =
    set (_CBlockEntry <<< cbeEpoch) epoch block

-- | Update hash of a slot
setHashOfBlock :: CHash -> CBlockEntry -> CBlockEntry
setHashOfBlock hash block =
    set (_CBlockEntry <<< cbeBlkHash) hash block

mkCTxBriefs :: Array Int -> CTxBriefs
mkCTxBriefs indexes =
    map mkCTxBrief indexes

mkCTxBrief :: Int -> CTxBrief
mkCTxBrief index = CTxBrief
    { ctbId: mkCTxId $ show index
    , ctbTimeIssued: Just $ mkTime 0.0
    , ctbInputs: mkCtbInputs [index]
    , ctbOutputs: mkCtbOutputs ((index + 1)..(index + 2))
    , ctbInputSum: mkCoin "0"
    , ctbOutputSum: mkCoin "0"
    }

mkCtbInput :: Int -> Int -> Maybe (Tuple CAddress CCoin)
mkCtbInput addr coin =
    Just $ Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbInputs :: Array Int -> Array (Maybe (Tuple CAddress CCoin))
mkCtbInputs indexes =
    map (\index -> mkCtbInput index index) indexes

mkCtbOutput :: Int -> Int -> Tuple CAddress CCoin
mkCtbOutput addr coin =
    Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbOutputs :: Array Int -> Array (Tuple CAddress CCoin)
mkCtbOutputs indexes =
    map (\index -> mkCtbOutput index index) indexes

mkCGenesisSummary :: CGenesisSummary
mkCGenesisSummary = CGenesisSummary
    { cgsNumTotal    : 4
    , cgsNumRedeemed : 3
    , cgsNumNotRedeemed: 1
    , cgsRedeemedAmountTotal: mkCoin "100"
    , cgsNonRedeemedAmountTotal: mkCoin "10"
    }

mkCGenesisAddressInfo :: CGenesisAddressInfo
mkCGenesisAddressInfo =
    -- Commenting out RSCoin addresses until they can actually be displayed.
    -- See comment in src/Pos/Explorer/Web/ClientTypes.hs for more information.
    CGenesisAddressInfo
    { cgaiCardanoAddress : mkCAddress "3meLwrCDE4C7RofEdkZbUuR75ep3EcTmZv9ebcdjfMtv5H"
    -- , cgaiRSCoinAddress  : mkCAddress "JwvXUQ31cvrFpqqtx6fB-NOp0Q-eGQs74yXMGa-72Ak="
    , cgaiGenesisAmount  : mkCoin "15000000"
    , cgaiIsRedeemed     : false
    }

-- | Helper functions to mock data.
-- |
-- | _Note_: All these functions are used for testing only.

module Explorer.Test.MockFactory where

import Prelude

import Data.Array ((..))
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Data.Time.NominalDiffTime (NominalDiffTime, mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Types.State (CTxBriefs)
import Explorer.Util.Factory (mkCAddress, mkCHash, mkCTxId, mkCoin)
import Pos.Explorer.Web.ClientTypes (CAddress, CAddressSummary(..), CAddressType(..), CBlockEntry(..), CCoin, CGenesisAddressInfo(..), CGenesisSummary(..), CHash, CTxBrief(..), CTxEntry(..), CTxId)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, _CBlockEntry, _CTxEntry, caTxList, cbeBlkHash, cbeEpoch, cbeSlot, cbeTimeIssued, cteId, cteTimeIssued)

-- | Creates a `CTxEntry` with "empty" data
mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: Just $ mkTime 0.0
    , cteAmount: mkCoin "0"
    }

-- | Update hash of a transcation
setIdOfTx :: CTxId -> CTxEntry -> CTxEntry
setIdOfTx txId tx =
    set (_CTxEntry <<< cteId) txId tx

-- | Update time of a transaction
setTimeOfTx :: NominalDiffTime -> CTxEntry -> CTxEntry
setTimeOfTx time tx =
    set (_CTxEntry <<< cteTimeIssued) (Just time) tx

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caType: CUnknownAddress
    , caTxNum: 0
    , caBalance: mkCoin "0"
    , caTxList: []
    }

-- | Update txs of a `CAddressSummary`
setTxOfAddressSummary :: CTxBriefs -> CAddressSummary -> CAddressSummary
setTxOfAddressSummary txs addr =
    set (_CAddressSummary <<< caTxList) txs addr

mkCBlockEntry :: CBlockEntry
mkCBlockEntry = CBlockEntry
    { cbeEpoch: 0
    , cbeSlot: 0
    , cbeBlkHash: mkCHash "0"
    , cbeTimeIssued: Nothing
    , cbeTxNum: 0
    , cbeTotalSent: mkCoin "0"
    , cbeFees: mkCoin "0"
    , cbeSize: 0
    , cbeBlockLead: Nothing
    }

-- | Update time of a slot
setTimeOfBlock :: NominalDiffTime -> CBlockEntry -> CBlockEntry
setTimeOfBlock time block =
    set (_CBlockEntry <<< cbeTimeIssued) (Just time) block

-- | Update slot / epoch of a slot
setEpochSlotOfBlock :: Int -> Int -> CBlockEntry -> CBlockEntry
setEpochSlotOfBlock epoch slot block =
    let block' = setEpochOfBlock epoch block in
    set (_CBlockEntry <<< cbeSlot) slot block'

-- | Update epoch of a slot
setEpochOfBlock :: Int -> CBlockEntry -> CBlockEntry
setEpochOfBlock epoch block =
    set (_CBlockEntry <<< cbeEpoch) epoch block

-- | Update hash of a slot
setHashOfBlock :: CHash -> CBlockEntry -> CBlockEntry
setHashOfBlock hash block =
    set (_CBlockEntry <<< cbeBlkHash) hash block

mkCTxBriefs :: Array Int -> CTxBriefs
mkCTxBriefs indexes =
    map mkCTxBrief indexes

mkCTxBrief :: Int -> CTxBrief
mkCTxBrief index = CTxBrief
    { ctbId: mkCTxId $ show index
    , ctbTimeIssued: Just $ mkTime 0.0
    , ctbInputs: mkCtbInputs [index]
    , ctbOutputs: mkCtbOutputs ((index + 1)..(index + 2))
    , ctbInputSum: mkCoin "0"
    , ctbOutputSum: mkCoin "0"
    }

mkCtbInput :: Int -> Int -> Maybe (Tuple CAddress CCoin)
mkCtbInput addr coin =
    Just $ Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbInputs :: Array Int -> Array (Maybe (Tuple CAddress CCoin))
mkCtbInputs indexes =
    map (\index -> mkCtbInput index index) indexes

mkCtbOutput :: Int -> Int -> Tuple CAddress CCoin
mkCtbOutput addr coin =
    Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbOutputs :: Array Int -> Array (Tuple CAddress CCoin)
mkCtbOutputs indexes =
    map (\index -> mkCtbOutput index index) indexes

mkCGenesisSummary :: CGenesisSummary
mkCGenesisSummary = CGenesisSummary
    { cgsNumTotal    : 4
    , cgsNumRedeemed : 3
    , cgsNumNotRedeemed: 1
    , cgsRedeemedAmountTotal: mkCoin "100"
    , cgsNonRedeemedAmountTotal: mkCoin "10"
    }

mkCGenesisAddressInfo :: CGenesisAddressInfo
mkCGenesisAddressInfo =
    -- Commenting out RSCoin addresses until they can actually be displayed.
    -- See comment in src/Pos/Explorer/Web/ClientTypes.hs for more information.
    CGenesisAddressInfo
    { cgaiCardanoAddress : mkCAddress "3meLwrCDE4C7RofEdkZbUuR75ep3EcTmZv9ebcdjfMtv5H"
    -- , cgaiRSCoinAddress  : mkCAddress "JwvXUQ31cvrFpqqtx6fB-NOp0Q-eGQs74yXMGa-72Ak="
    , cgaiGenesisAmount  : mkCoin "15000000"
    , cgaiIsRedeemed     : false
    }


Add AVar bindings

Add AVar bindings

module Control.Monad.Aff.AVar
  ( module Control.Monad.Eff.AVar
  , makeVar
  , makeEmptyVar
  , isEmptyVar
  , takeVar
  , tryTakeVar
  , putVar
  , tryPutVar
  , readVar
  , tryReadVar
  , killVar
  ) where

import Prelude
import Control.Monad.Aff (Aff, Canceler(..), makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.AVar (AVar, AVAR)
import Control.Monad.Eff.AVar as AVar
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Data.Maybe (Maybe)

toCanceler ∷ ∀ eff. Eff eff Unit → Canceler eff
toCanceler = Canceler <<< const <<< liftEff

makeVar ∷ ∀ eff a. a → Aff (avar ∷ AVAR | eff) (AVar a)
makeVar = liftEff <<< AVar.makeVar

makeEmptyVar ∷ ∀ eff a. Aff (avar ∷ AVAR | eff) (AVar a)
makeEmptyVar = liftEff AVar.makeEmptyVar

isEmptyVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) Boolean
isEmptyVar = liftEff <<< AVar.isEmptyVar

takeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a
takeVar avar = makeAff \k → do
  c ← AVar.takeVar avar k
  pure (toCanceler c)

tryTakeVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a)
tryTakeVar = liftEff <<< AVar.tryTakeVar

putVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Unit
putVar avar value = makeAff \k → do
  c ← AVar.putVar avar value k
  pure (toCanceler c)

tryPutVar ∷ ∀ eff a. AVar a → a → Aff (avar ∷ AVAR | eff) Boolean
tryPutVar avar = liftEff <<< AVar.tryPutVar avar

readVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) a
readVar avar = makeAff \k → do
  c ← AVar.readVar avar k
  pure (toCanceler c)

tryReadVar ∷ ∀ eff a. AVar a → Aff (avar ∷ AVAR | eff) (Maybe a)
tryReadVar = liftEff <<< AVar.tryReadVar

killVar ∷ ∀ eff a. AVar a → Error → Aff (avar ∷ AVAR | eff) Unit
killVar avar = liftEff <<< AVar.killVar avar

module Control.Monad.Aff.AVar where

-- TODO


cleanup.

cleanup.

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

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

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = (const DeleteTopic) <$> (lookup "dragOverTrash")

  -- HTML 5 fires dragLeave before dragEnd occurs
  -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ (const UnassignTopic)
                  <$> ((lookup "dragLeaveSlot") `merge` (lookup "dragLeaveTrash"))

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = (parseTopic <<< getDetail)
                  <$> (lookup "dragStartTopic" `merge` lookup "dragStartGridTopic")

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

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

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
  let dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

  let dragOverTrash = (const DeleteTopic) <$> (lookup "dragOverTrash")

  -- HTML 5 fires dragLeave before dragEnd occurs
  -- TODO: Find a cleaner solution
  let dragLeave = delay 30 $ (const UnassignTopic)
                  <$> ((lookup "dragLeaveSlot") `merge` (lookup "dragLeaveTrash"))

  let dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

  let dragStart = (parseTopic <<< getDetail)
                  <$> (lookup "dragStartTopic" `merge` lookup "dragStartGridTopic")

  let dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
  let addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
  let addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
  let removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
  let addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
  let deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
  let changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)