draw chr labels on track

draw chr labels on track

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.), (^?))
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(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (class Unfoldable, none)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(CoordSys), Interval, Normalized(Normalized), _BrowserIntervals, _CoordSys, _Index, _Interval, intervalToScreen, nPointToFrame, normPoint, viewIntervals)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

gwasDraw :: forall a. Color -> a -> Drawing
gwasDraw color =
  let r = 2.2
      c = circle 0.0 0.0 r
      out = outlined (outlineColor color) c
      fill = filled (fillColor color) c
  in const $ out <> fill

gwasPlace :: forall a r.
             { min :: Number, max :: Number | r }
          -> { chrSize :: a -> Maybe Bp
             , pos     :: a -> Bp
             , score   :: a -> Number }
          -> a
          -> Maybe (Normalized Point)
gwasPlace {min, max} get a = do
  size <- get.chrSize a
  let x = unwrap $ (get.pos a) / size
      y = (get.score a - min) / (max - min)
  normPoint {x, y}

gwasRenderer :: forall r rf.
                { min :: Number, max :: Number | r }
             -> Array (GWASFeature rf)
             -> { drawing :: Drawing
                , points :: Array (Normalized Point) }
gwasRenderer vs gwas = { drawing, points }
  where get = { chrSize: \a -> Map.lookup a.chrId mouseChrs
              , pos: _.pos, score: _.score }
        drawing = gwasDraw red unit
        points = filterMap (gwasPlace vs get) gwas

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               => {min :: Number, max :: Number, sig :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }
  pure renderer

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

drawPureInterval :: forall f r .
                    Foldable f
                 => { height :: Pixels | r }
                 -> { width :: Pixels, offset :: Pixels }
                 -> f { drawing :: Drawing, point :: Normalized Point }
                 -> Drawing
drawPureInterval {height} {width, offset} = foldMap render'
  where render' {drawing, point} =
          let {x,y} = nPointToFrame width height $ point
          in translate (x + offset) y drawing

drawFrames :: forall i a.
              Ord i
           => CoordSys i BrowserPoint
           -> { width :: Pixels, height :: Pixels }
           -> Map i (Array { drawing :: _, point :: _ })
           -> Interval BrowserPoint
           -> Drawing
drawFrames cs@(CoordSys s) canvasBox drawings =
  let f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> Array { drawing :: _, point :: _ }
      g c = fromMaybe [] $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> Array (Tuple _ (Array _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$> (viewIntervals cs iv)

      drawIvs :: Array (Tuple _ (Array _)) -> Drawing
      drawIvs = foldMap (uncurry $ drawPureInterval canvasBox)

      drawIvs' :: Array (Tuple _ (Array _)) -> Array Drawing
      drawIvs' = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 canvasBox.height
                $ scale 1.0 (-1.0)
                $ drawIvs (toDraw bView)

drawData :: forall i c f a.
            Ord i
         => Foldable f
         => Filterable f
         => CoordSys i BrowserPoint
         -> { width :: Pixels, height :: Pixels }
         -> PureRenderer a
         -> Map i (f a)
         -> Interval BrowserPoint
         -> Drawing
drawData cs@(CoordSys s) canvasBox renderer dat =
  let drawings :: Map i (Array { drawing :: _, point :: _ })
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> Array { drawing :: _, point :: _ }
      g c = fromMaybe [] $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> Array (Tuple _ (Array _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$> (viewIntervals cs iv)

      drawIvs :: Array (Tuple _ (Array _)) -> Drawing
      drawIvs = foldMap (uncurry $ drawPureInterval canvasBox)

      drawIvs' :: Array (Tuple _ (Array _)) -> Array Drawing
      drawIvs' = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 canvasBox.height
                $ scale 1.0 (-1.0)
                $ drawIvs (toDraw bView)

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number, sig :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: forall r.
                 { min :: Number, max :: Number, sig :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r r1.
         { min :: Number, max :: Number, sig :: Number }
      -> Color
      -> { width :: Pixels, height :: Pixels }
      -> Drawing
ruler {min, max, sig} color f = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabels :: forall c.
             CoordSys ChrId c
          -> Map ChrId (Array { drawing :: _, point :: _ })
chrLabels cs = Map.fromFoldable results
  where mkLabel :: ChrId -> _
        mkLabel chr = { drawing: chrText chr, point: Normalized {x: 1.0, y: -0.1} }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = scale 1.0 (-1.0)
                    $ Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals
drawDemo :: forall f r.
            Foldable f
         => Filterable f
         => CoordSys _ _
         -> { min :: Number, max :: Number, sig :: Number }
         -> { width :: Pixels, height :: Pixels }
         -> { gwas   :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Interval BrowserPoint
         -> Drawing
drawDemo cs s canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s red
      drawGwas   = drawData cs canvasBox renderers.gwas gwas
      drawAnnots = drawData cs canvasBox renderers.annots annots
  in \view -> (drawGwas view) <> (drawAnnots view) <> ruler' canvasBox

{-
TODO
there is currently no connection between the vertical scale's
position and the track. Need to take stuff like vertical
offset and padding into account; calculate once and use
in both places. However don't just use canvasheight - yoffset
or whatever; actually derive the top and bottom of the track.
-}

drawVScale :: forall r.
              Number
           -> Number
           -> { min :: Number, max :: Number, sig :: Number }
           -> Color
           -> Drawing
drawVScale width height vs col =
  -- should have some padding here too; hardcode for now
  let hPad = width  / 5.0
      vPad = height / 10.0
      x = width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vs.max
      btmLabel = mkT (y2+vPad) $ show vs.min

  in outlined (outlineColor col <> lineWidth 2.0) (p <> ps)
  <> topLabel <> btmLabel

drawLegendItem :: Number
               -> { text :: String, icon :: Drawing }
               -> Drawing
drawLegendItem w {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Number
           -> Number
           -> Array { text :: String, icon :: Drawing }
           -> Drawing
drawLegend width height icons =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length icons
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem (width - 2.0*hPad) ic
      d = (height - 2.0*vPad) / (length icons)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) icons
  in fold ds

mkIcon :: Color -> String -> { text :: String, icon :: Drawing }
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

demoLegend :: Array {text :: String, icon :: Drawing}
demoLegend =
  [ mkIcon red "Red thing"
  , mkIcon blue "blue thing"
  , mkIcon purple "boop"
  ]

              -- the first 2 are used by all parts of the browser
demoBrowser :: forall f.
               Foldable f
            => Filterable f
            => CoordSys ChrId BrowserPoint
            -> { width :: Pixels, height :: Pixels }
            -> Pixels
            -- this by the vertical scale and the tracks
            -> { min :: Number, max :: Number, sig :: Number }
            -- these define the width of the non-track parts of the browser;
            -- the browser takes up the remaining space.
            -> { vScaleWidth :: Pixels
               , legendWidth :: Pixels }
            -- vScale only
            -> Color
            -- to be drawn in the legend on the RHS
            -> Array { text :: String, icon :: Drawing }
            -- finally, used by the main track
            -> { gwas :: Map ChrId (f (GWASFeature ()))
               , annots :: Map ChrId (f (Annot (minY :: Number))) }
            -> BrowserView
            -- the drawing produced contains all 3 parts.
            -> { track :: Drawing, overlay :: Drawing }
demoBrowser cs canvas vpadding vscale sizes vscaleColor legend {gwas, annots} =
  let height = canvas.height - 2.0 * vpadding
      width  = canvas.width

      trackCanvas = { width: canvas.width - sizes.vScaleWidth - sizes.legendWidth
                    , height }

      bg w' h' = filled (fillColor white) $ rectangle 0.0 0.0 w' h'

      -- TODO unify vertical offset by padding further; do it as late as possible

      vScale :: _ -> Drawing
      vScale _ = let w = sizes.vScaleWidth
                 in  translate zero vpadding
                   $ bg w height
                  <> drawVScale w height vscale vscaleColor

      track v = translate sizes.vScaleWidth vpadding
                  $ drawDemo cs vscale trackCanvas {gwas, annots} v

      chrs :: _ -> Drawing
      chrs v = translate zero vpadding
                 $ drawFrames cs trackCanvas (chrLabels cs) v

      legendD :: _ -> Drawing
      legendD _ = let w = sizes.legendWidth
                  in translate (canvas.width - w) vpadding
                    $ bg w height
                   <> drawLegend sizes.legendWidth canvas.height legend

  in \view -> { track: track view <> chrs view
              , overlay: vScale view <> legendD view }

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ map (\x -> Tuple x {color: navy}) mouseChrIds

mouseColors' :: ChrCtx (color :: Color)
mouseColors' = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
               [ navy, blue, aqua, teal, olive
               , green, lime, yellow, orange, red
               , maroon, fuchsia, purple, navy, blue
               , aqua, teal, olive, green, lime
               , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.), (^?))
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(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (class Unfoldable, none)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(CoordSys), Interval, Normalized(Normalized), _Index, _Interval, intervalToScreen, nPointToFrame, normPoint, viewIntervals)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

gwasDraw :: forall a. Color -> a -> Drawing
gwasDraw color =
  let r = 2.2
      c = circle 0.0 0.0 r
      out = outlined (outlineColor color) c
      fill = filled (fillColor color) c
  in const $ out <> fill

gwasPlace :: forall a r.
             { min :: Number, max :: Number | r }
          -> { chrSize :: a -> Maybe Bp
             , pos     :: a -> Bp
             , score   :: a -> Number }
          -> a
          -> Maybe (Normalized Point)
gwasPlace {min, max} get a = do
  size <- get.chrSize a
  let x = unwrap $ (get.pos a) / size
      y = (get.score a - min) / (max - min)
  normPoint {x, y}

gwasRenderer :: forall r rf.
                { min :: Number, max :: Number | r }
             -> Array (GWASFeature rf)
             -> { drawing :: Drawing
                , points :: Array (Normalized Point) }
gwasRenderer vs gwas = { drawing, points }
  where get = { chrSize: \a -> Map.lookup a.chrId mouseChrs
              , pos: _.pos, score: _.score }
        drawing = gwasDraw red unit
        points = filterMap (gwasPlace vs get) gwas

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               => {min :: Number, max :: Number, sig :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }
  pure renderer

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

drawPureInterval :: forall f r .
                    Foldable f
                 => { height :: Pixels | r }
                 -> { width :: Pixels, offset :: Pixels }
                 -> f { drawing :: Drawing, point :: Normalized Point }
                 -> Drawing
drawPureInterval {height} {width, offset} = foldMap render'
  where render' {drawing, point} =
          let {x,y} = nPointToFrame width height $ point
          in translate (x + offset) y drawing

drawData :: forall i c f a.
            Ord i
         => Foldable f
         => Filterable f
         => CoordSys i BrowserPoint
         -> { width :: Pixels, height :: Pixels }
         -> PureRenderer a
         -> Map i (f a)
         -> Interval BrowserPoint
         -> Drawing
drawData cs@(CoordSys s) canvasBox renderer dat =
  let drawings :: Map i (Array { drawing :: _, point :: _ })
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> Array { drawing :: _, point :: _ }
      g c = fromMaybe [] $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> Array (Tuple _ (Array _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$> (viewIntervals cs iv)

      drawIvs :: Array (Tuple _ (Array _)) -> Drawing
      drawIvs = foldMap (uncurry $ drawPureInterval canvasBox)

      drawIvs' :: Array (Tuple _ (Array _)) -> Array Drawing
      drawIvs' = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 canvasBox.height
                $ scale 1.0 (-1.0)
                $ drawIvs (toDraw bView)

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number, sig :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: forall r.
                 { min :: Number, max :: Number, sig :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r r1.
         { min :: Number, max :: Number, sig :: Number }
      -> Color
      -> { width :: Pixels, height :: Pixels }
      -> Drawing
ruler {min, max, sig} color f = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

drawDemo :: forall f r.
            Foldable f
         => Filterable f
         => CoordSys _ _
         -> { min :: Number, max :: Number, sig :: Number }
         -> { width :: Pixels, height :: Pixels }
         -> { gwas   :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Interval BrowserPoint
         -> Drawing
drawDemo cs s canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s red
      drawGwas   = drawData cs canvasBox renderers.gwas gwas
      drawAnnots = drawData cs canvasBox renderers.annots annots
  in \view -> (drawGwas view) <> (drawAnnots view) <> ruler' canvasBox

{-
TODO
there is currently no connection between the vertical scale's
position and the track. Need to take stuff like vertical
offset and padding into account; calculate once and use
in both places. However don't just use canvasheight - yoffset
or whatever; actually derive the top and bottom of the track.
-}

drawVScale :: forall r.
              Number
           -> Number
           -> { min :: Number, max :: Number, sig :: Number }
           -> Color
           -> Drawing
drawVScale width height vs col =
  -- should have some padding here too; hardcode for now
  let hPad = width  / 5.0
      vPad = height / 10.0
      x = width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vs.max
      btmLabel = mkT (y2+vPad) $ show vs.min

  in outlined (outlineColor col <> lineWidth 2.0) (p <> ps)
  <> topLabel <> btmLabel

drawLegendItem :: Number
               -> { text :: String, icon :: Drawing }
               -> Drawing
drawLegendItem w {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Number
           -> Number
           -> Array { text :: String, icon :: Drawing }
           -> Drawing
drawLegend width height icons =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length icons
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem (width - 2.0*hPad) ic
      d = (height - 2.0*vPad) / (length icons)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) icons
  in fold ds

mkIcon :: Color -> String -> { text :: String, icon :: Drawing }
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

demoLegend :: Array {text :: String, icon :: Drawing}
demoLegend =
  [ mkIcon red "Red thing"
  , mkIcon blue "blue thing"
  , mkIcon purple "boop"
  ]

              -- the first 2 are used by all parts of the browser
demoBrowser :: forall f.
               Foldable f
            => Filterable f
            => CoordSys ChrId BrowserPoint
            -> { width :: Pixels, height :: Pixels }
            -> Pixels
            -- this by the vertical scale and the tracks
            -> { min :: Number, max :: Number, sig :: Number }
            -- these define the width of the non-track parts of the browser;
            -- the browser takes up the remaining space.
            -> { vScaleWidth :: Pixels
               , legendWidth :: Pixels }
            -- vScale only
            -> Color
            -- to be drawn in the legend on the RHS
            -> Array { text :: String, icon :: Drawing }
            -- finally, used by the main track
            -> { gwas :: Map ChrId (f (GWASFeature ()))
               , annots :: Map ChrId (f (Annot (minY :: Number))) }
            -> BrowserView
            -- the drawing produced contains all 3 parts.
            -> { track :: Drawing, overlay :: Drawing }
demoBrowser cs canvas vpadding vscale sizes vscaleColor legend {gwas, annots} =
  let height = canvas.height - 2.0 * vpadding
      width  = canvas.width

      trackCanvas = { width: canvas.width - sizes.vScaleWidth - sizes.legendWidth
                    , height }

      bg w' h' = filled (fillColor white) $ rectangle 0.0 0.0 w' h'

      -- TODO unify vertical offset by padding further; do it as late as possible

      vScale :: _ -> Drawing
      vScale _ = let w = sizes.vScaleWidth
                 in  translate zero vpadding
                   $ bg w height
                  <> drawVScale w height vscale vscaleColor

      track v = translate sizes.vScaleWidth vpadding
                  $ drawDemo cs vscale trackCanvas {gwas, annots} v

      legendD :: _ -> Drawing
      legendD _ = let w = sizes.legendWidth
                  in translate (canvas.width - w) vpadding
                    $ bg w height
                   <> drawLegend sizes.legendWidth canvas.height legend

  in \view -> { track: track view
              , overlay: vScale view <> legendD view }

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ map (\x -> Tuple x {color: navy}) mouseChrIds

mouseColors' :: ChrCtx (color :: Color)
mouseColors' = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
               [ navy, blue, aqua, teal, olive
               , green, lime, yellow, orange, red
               , maroon, fuchsia, purple, navy, blue
               , aqua, teal, olive, green, lime
               , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs


Refactoring/cleanup

Refactoring/cleanup

module Gauge where

import Prelude
import Data.Maybe
import Data.Array
import Data.Map as Map
import CSS (background)
import Data.Map (Map)
import Data.Monoid (class Monoid, mempty)
import Data.Time (Time)
import Data.Tuple (Tuple(..))

import Pux.Html.Events (onClick)
import Pux.Html.Attributes (style)
import Pux.Html as H

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate

derive instance viewTypeEq :: Eq ViewType

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

data Action = UpdateStats (Array NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: Array NodeStats }

-- /todo: Add Node = String | IPAddress
newtype BStats = BStats Int

instance bstatsSemigroup :: Semigroup BStats where
    append (BStats b1) (BStats b2 ) = BStats (b1 + b2)
instance bstatsMonoid :: Monoid BStats where
    mempty = BStats 0
instance bstatsShow :: Show BStats where
    show (BStats b) = show b

type Node = String

newtype Broker = Broker { name :: Node, port :: Int }

derive instance brokerEq :: Eq Broker
derive instance brokerOrd :: Ord Broker

instance brokerShow :: Show Broker where
    show (Broker {name,port}) = show name <> ":" <> show port

type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: Array BrokerStats}

init :: State
init = { viewType : PerBroker, stats : [] }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (Array NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # numConnections >>> show

viewAs :: ViewType -> (Array NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    (s # map \{node,brokers} ->
        let agg = brokers # map _.connections >>> fold in
        H.div []
            [ H.h1  [] [H.text $ show node]
            , viewStats agg ])

viewAs PerBroker s =
    let
        mergeBrokerStats {broker, connections} = addOrInsert connections broker
        statsPerBroker = s # concatMap _.brokers
                           >>> foldr mergeBrokerStats Map.empty
                           >>> Map.toAscUnfoldable
    in
    H.div []
    (statsPerBroker # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [H.text $ show broker]
            , viewStats agg])

viewAs PerNodeAndBroker s =
    H.div [] $
    s # concatMap (\{node,brokers} -> brokers # map \brokerStats -> {node,brokerStats})
    >>> (map \{node,brokerStats} ->
        H.div []
        [ H.h1  [] [H.text $ "Node: " <> show node <> " Broker: " <> show brokerStats.broker]
            , viewStats brokerStats.connections])

viewAs Aggregate s =
    let agg = numConnections s in
    H.div []
        [ H.h1  [] [H.text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [H.text "Connections:"]
        , H.p  [] [H.text $ show stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.ul []
     (optionView viewType <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView sel v =
    H.li
        (if v == sel then [] else [E.onClick $ const (ChangeView v)])
        [H.text $ show v]

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

numConnections :: Array NodeStats -> BStats
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> fold

upsert :: forall k v. (Monoid v, Ord k) => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

updateJust f = emptyIfNothing >>> f >>> Just

addOrInsert :: forall k v. (Monoid v, Ord k) => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty

module Gauge where

import Prelude
import Data.Maybe
import Data.Monoid (class Monoid, mempty)
import Data.Array
import Data.Tuple (Tuple(..))
import Data.Time (Time)
import Data.Map as Map
import Data.Map (Map)

import Pux.Html.Events (onClick)
import Pux.Html as H
--import Pux.CSS as CSS
import Pux.Html.Events as E

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate

derive instance viewTypeEq :: Eq ViewType

data Action = UpdateStats (Array NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: Array NodeStats }

-- /todo: Add Node = String | IPAddress
newtype BStats = BStats Int
instance bstatsSemigroup :: Semigroup BStats where
    append (BStats b1) (BStats b2 ) = BStats (b1 + b2)
instance bstatsMonoid :: Monoid BStats where
    mempty = BStats 0
instance bstatsShow :: Show BStats where
    show (BStats b) = show b

type Node = String

newtype Broker = Broker { name :: Node, port :: Int }

derive instance brokerEq :: Eq Broker
derive instance brokerOrd :: Ord Broker

instance brokerShow :: Show Broker where
    show (Broker {name,port}) = show name <> ":" <> show port
-- instance brokerOrd :: Ord Broker where
--     compare (Broker {name:n1, port:p1}) (Broker {name:n2, port:p2}) = (compare n1 n2) <> (compare p1 p2)

type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: Array BrokerStats}

init :: State
init = { viewType : PerBroker, stats : [] }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (Array NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # numConnections >>> show

viewAs :: ViewType -> (Array NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    (s # map \{node,brokers} ->
        let agg = brokers # map _.connections >>> fold in
        H.div []
            [ H.h1  [] [H.text $ show node]
            , viewStats agg ])

viewAs PerBroker s =
    let
        mergeBrokerStats m {broker, connections} = addOrInsert connections broker m
        statsPerBroker = s # concatMap _.brokers
                           >>> foldl mergeBrokerStats Map.empty
                           >>> Map.toAscUnfoldable
    in
    H.div []
    (statsPerBroker # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [H.text $ show broker]
            , viewStats agg])

viewAs PerNodeAndBroker s =
    H.div [] $
    s # concatMap (\{node,brokers} -> brokers # map \brokerStats -> {node,brokerStats})
    >>> (map \{node,brokerStats} ->
        H.div []
        [ H.h1  [] [H.text $ "Node: " <> node <> " Broker: " <> show brokerStats.broker]
            , viewStats brokerStats.connections])

viewAs Aggregate s =
    let agg = numConnections s in
    H.div []
        [ H.h1  [] [H.text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [H.text "Connections:"]
        , H.p  [] [H.text $ show stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.ul []
     (optionView viewType <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView sel v =
    H.li
        (if v == sel then [] else [E.onClick $ const (ChangeView v)])
        [H.text $ show v]

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

numConnections :: Array NodeStats -> BStats
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> fold

upsert :: forall k v. (Monoid v, Ord k) => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

updateJust f = emptyIfNothing >>> f >>> Just

addOrInsert :: forall k v. (Monoid v, Ord k) => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty


Test.Helper.createDomRoot does not need to return unit explicitly

module Test.Helper (
    unsafeFindElement
  , createDomRoot
  , afterAll
  ) where

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent)
import DOM.Node.ParentNode (QuerySelector(QuerySelector), querySelector)
import DOM.Node.Types (Document, Element, documentToParentNode, elementToNode)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (Unit, bind, pure, ($), (<>))
import Unsafe.Coerce (unsafeCoerce)

unsafeFindElement :: forall e m. (MonadEff (dom :: DOM | e) m) => String -> m Element
unsafeFindElement queryStr = liftEff do
  doc <- getDocument
  maybeElem <- querySelector (QuerySelector queryStr) (documentToParentNode doc)
  case maybeElem of
    Nothing -> unsafeCrashWith $ "Element for query '" <> queryStr <> "' was not found."
    Just elem -> pure elem

getDocument ::  forall e m. (MonadEff (dom :: DOM | e) m) => m Document
getDocument = liftEff do
  wndow <- window
  doc <- document wndow
  pure $ htmlDocumentToDocument doc

createDomRoot :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
createDomRoot = liftEff do
  doc <- getDocument
  bdy <- unsafeFindElement "body"
  node <- createElement "div" doc
  child <- appendChild (elementToNode node) (elementToNode bdy)
  setAttribute "id" "app" (unsafeCoerce child)

afterAll :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
afterAll = liftEff do
  doc <- getDocument
  node <- createElement "div" doc
  bdy <- unsafeFindElement "body"
  setTextContent "" (unsafeCoerce bdy)

module Test.Helper (
    unsafeFindElement
  , createDomRoot
  , afterAll
  ) where

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent)
import DOM.Node.ParentNode (QuerySelector(QuerySelector), querySelector)
import DOM.Node.Types (Document, Element, documentToParentNode, elementToNode)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (Unit, bind, discard, pure, unit, ($), (<>))
import Unsafe.Coerce (unsafeCoerce)

unsafeFindElement :: forall e m. (MonadEff (dom :: DOM | e) m) => String -> m Element
unsafeFindElement queryStr = liftEff do
  doc <- getDocument
  maybeElem <- querySelector (QuerySelector queryStr) (documentToParentNode doc)
  case maybeElem of
    Nothing -> unsafeCrashWith $ "Element for query '" <> queryStr <> "' was not found."
    Just elem -> pure elem

getDocument ::  forall e m. (MonadEff (dom :: DOM | e) m) => m Document
getDocument = liftEff do
  wndow <- window
  doc <- document wndow
  pure $ htmlDocumentToDocument doc

createDomRoot :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
createDomRoot = liftEff do
  doc <- getDocument
  bdy <- unsafeFindElement "body"
  node <- createElement "div" doc
  child <- appendChild (elementToNode node) (elementToNode bdy)
  setAttribute "id" "app" (unsafeCoerce child)
  pure unit

afterAll :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
afterAll = liftEff do
  doc <- getDocument
  node <- createElement "div" doc
  bdy <- unsafeFindElement "body"
  setTextContent "" (unsafeCoerce bdy)


connect_: subscribe in componetDidMount

connect_: subscribe in componetDidMount

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentDidMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl


Fix docs

Fix docs

module Test.Main where

import Data.Tuple
import Data.Maybe
import Data.Array (zipWith, length, updateAt, deleteAt, (..), (!!))

import Debug.Trace

import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal

import qualified Halogen.Mixin.UndoRedo as U

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Forms as A

import qualified Halogen.Themes.Bootstrap3 as B

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

type Task = { description :: String, completed :: Boolean }

-- | The state of the application
data State = State [Task]

-- | Inputs to the state machine:
-- |
-- | - `SetCounter n` - a request to update the counter to value `n`
data Input
  = NewTask
  | UpdateDescription Number String
  | MarkCompleted Number Boolean
  | RemoveTask Number
  | Undo
  | Redo

instance inputSupportsUndoRedo :: U.SupportsUndoRedo Input where
  fromUndoRedo U.Undo = Undo
  fromUndoRedo U.Redo = Redo
  toUndoRedo Undo = Just U.Undo
  toUndoRedo Redo = Just U.Redo
  toUndoRedo _ = Nothing

-- | The UI is a state machine, consuming inputs, and generating HTML documents which in turn, generate new inputs
ui :: forall eff. SF1 Input (H.HTML Input)
ui = view <$> stateful (U.undoRedoState (State [])) (U.withUndoRedo update)
  where
  view :: U.UndoRedoState State -> H.HTML Input
  view st =
    case U.getState st of
      State ts ->
        H.div (A.class_ B.container)
              [ H.h1 (A.id_ "header") [ H.text "todo list" ]
              , toolbar st
              , tasks ts
              ]

  toolbar :: forall st. U.UndoRedoState st -> H.HTML Input
  toolbar st = H.p (A.class_ B.btnGroup)
                   [ H.button ( A.classes [ B.btn, B.btnPrimary ]
                                <> A.onclick (const NewTask) )
                              [ H.text "New Task" ]
                   , H.button ( A.class_ B.btn
                                <> A.enabled (U.canUndo st)
                                <> A.onclick (const Undo) )
                              [ H.text "Undo" ]
                   , H.button ( A.class_ B.btn
                                <> A.enabled (U.canRedo st)
                                <> A.onclick (const Redo) )
                              [ H.text "Redo" ]
                   ]

  tasks :: [Task] -> H.HTML Input
  tasks ts = H.table (A.classes [ B.table, B.tableStriped ])
                     [ H.thead_ [ H.th_ [ H.text "Task" ]
                                , H.th_ [ H.text "Completed" ]
                                , H.th_ []
                                ]
                     , H.tbody_ (zipWith task ts (0 .. length ts))
                     ]

  task :: Task -> Number -> H.HTML Input
  task task index =
    H.tr_ [ H.td_ [ H.input ( A.classes [ B.formControl ]
                              <> A.placeholder "Description"
                              <> A.onValueChanged (UpdateDescription index)
                              <> A.value task.description )
                            [] ]
          , H.td_ [ H.input ( A.classes [ B.formControl, B.checkbox]
                              <> A.type_ "checkbox"
                              <> A.checked task.completed
                              <> A.title "Mark as completed"
                              <> A.onChecked (MarkCompleted index) )
                            [] ]
          , H.td_ [ H.button ( A.classes [ B.btn, B.btnDefault ]
                               <> A.title "Remove task"
                               <> A.onclick \_ -> RemoveTask index )
                             [ H.text "✖" ] ]
          ]

  update :: State -> Input -> State
  update (State ts) NewTask = State (ts ++ [{ description: "", completed: false }])
  update (State ts) (UpdateDescription i description) = State $ modifyAt i (_ { description = description }) ts
  update (State ts) (MarkCompleted i completed) = State $ modifyAt i (_ { completed = completed }) ts
  update (State ts) (RemoveTask i) = State $ deleteAt i 1 ts

  -- TODO: move this into purescript-arrays
  modifyAt :: forall a. Number -> (a -> a) -> [a] -> [a]
  modifyAt i f xs = case xs !! i of
                      Just x -> updateAt i (f x) xs
                      Nothing -> xs

main = do
  node <- runUI ui
  appendToBody node

module Test.Main where

import Data.Tuple
import Data.Maybe
import Data.Array (zipWith, length, updateAt, deleteAt, (..), (!!))

import Debug.Trace

import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal

import qualified Halogen.Mixin.UndoRedo as U

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Forms as A

import qualified Halogen.Themes.Bootstrap3 as B

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

type Task = { description :: String, completed :: Boolean }

-- | The state of the application
data State = State [Task]

-- | Inputs to the state machine:
-- |
-- | - `SetCounter n` - a request to update the counter to value `n`
data Input
  = NewTask
  | UpdateDescription Number String
  | MarkCompleted Number Boolean
  | RemoveTask Number
  | Undo
  | Redo

instance inputSupportsUndoRedo :: U.SupportsUndoRedo Input where
  fromUndoRedo U.Undo = Undo
  fromUndoRedo U.Redo = Redo
  toUndoRedo Undo = Just U.Undo
  toUndoRedo Redo = Just U.Redo
  toUndoRedo _ = Nothing

-- | External requests:
-- |
-- | - `AddService n m` - send a request to an external service to add the numbers `n` and `m`
data Request = AddService Number Number

-- | The UI is a state machine, consuming errors and inputs, and generating HTML documents which generate
-- | external service requests of type `Request`.
ui :: forall eff. SF1 Input (H.HTML Input)
ui = view <$> stateful (U.undoRedoState (State [])) (U.withUndoRedo update)
  where
  view :: U.UndoRedoState State -> H.HTML Input
  view st =
    case U.getState st of
      State ts ->
        H.div (A.class_ B.container)
              [ H.h1 (A.id_ "header") [ H.text "todo list" ]
              , toolbar st
              , tasks ts
              ]

  toolbar :: forall st. U.UndoRedoState st -> H.HTML Input
  toolbar st = H.p (A.class_ B.btnGroup)
                   [ H.button ( A.classes [ B.btn, B.btnPrimary ]
                                <> A.onclick (const NewTask) )
                              [ H.text "New Task" ]
                   , H.button ( A.class_ B.btn
                                <> A.enabled (U.canUndo st)
                                <> A.onclick (const Undo) )
                              [ H.text "Undo" ]
                   , H.button ( A.class_ B.btn
                                <> A.enabled (U.canRedo st)
                                <> A.onclick (const Redo) )
                              [ H.text "Redo" ]
                   ]

  tasks :: [Task] -> H.HTML Input
  tasks ts = H.table (A.classes [ B.table, B.tableStriped ])
                     [ H.thead_ [ H.th_ [ H.text "Task" ]
                                , H.th_ [ H.text "Completed" ]
                                , H.th_ []
                                ]
                     , H.tbody_ (zipWith task ts (0 .. length ts))
                     ]

  task :: Task -> Number -> H.HTML Input
  task task index =
    H.tr_ [ H.td_ [ H.input ( A.classes [ B.formControl ]
                              <> A.placeholder "Description"
                              <> A.onValueChanged (UpdateDescription index)
                              <> A.value task.description )
                            [] ]
          , H.td_ [ H.input ( A.classes [ B.formControl, B.checkbox]
                              <> A.type_ "checkbox"
                              <> A.checked task.completed
                              <> A.title "Mark as completed"
                              <> A.onChecked (MarkCompleted index) )
                            [] ]
          , H.td_ [ H.button ( A.classes [ B.btn, B.btnDefault ]
                               <> A.title "Remove task"
                               <> A.onclick \_ -> RemoveTask index )
                             [ H.text "✖" ] ]
          ]

  update :: State -> Input -> State
  update (State ts) NewTask = State (ts ++ [{ description: "", completed: false }])
  update (State ts) (UpdateDescription i description) = State $ modifyAt i (_ { description = description }) ts
  update (State ts) (MarkCompleted i completed) = State $ modifyAt i (_ { completed = completed }) ts
  update (State ts) (RemoveTask i) = State $ deleteAt i 1 ts

  -- TODO: move this into purescript-arrays
  modifyAt :: forall a. Number -> (a -> a) -> [a] -> [a]
  modifyAt i f xs = case xs !! i of
                      Just x -> updateAt i (f x) xs
                      Nothing -> xs

main = do
  node <- runUI ui
  appendToBody node