added smallcheck example

added smallcheck example

module PreludeTests where

import Control.Monad.Eff
import Data.Eq
import Debug.Trace
import Test.QuickCheck
import Test.QuickCheck.LCG
import Control.Monad.Trampoline
import Data.Monoid
import Data.Tuple
import Data.Maybe
import Data.Foldable
import qualified Data.Array as Array
import qualified Math as Math

between :: forall a. (Ord a) => a -> a -> a -> Boolean
between min max = \n -> n >= min && n <= max

data Mega  = Mega {
  arrayOf     :: [Number],
  arrayOf1    :: [Number],
  choose      :: Number,
  chooseInt   :: Number,
  collectAll  :: [Number],
  allInArray  :: [Number],
  allInRange  :: [Number],
  dropGen     :: [Number],
  takeGen     :: [Number],
  elements    :: [String],
  extend      :: [String],
  infinite    :: [String] }

{- TODO: Remaining cases
  , frequency
  , oneOf
  , perturbGen
  , repeatable
  , resize
  , sample
  , sample'
  , showSample
  , showSample'
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , unfoldGen
  , uniform
  , variant
  , vectorOf
  -}

data DetABC = DetABC String

runDetABC :: DetABC -> String
runDetABC (DetABC s) = s

instance arbDetABC :: Arbitrary DetABC where
  arbitrary = DetABC <$> allInArray ["A", "B", "C"]

data OneToTen = OneToTen Number

runOneToTen :: OneToTen -> Number
runOneToTen (OneToTen n) = n

instance arbOneToTen :: Arbitrary OneToTen where
  arbitrary = OneToTen <$> chooseInt 0 10

instance arbMega :: Arbitrary Mega where
  arbitrary = do
    arrayOf'    <- arrayOf (choose 0 10)
    arrayOf1'   <- arrayOf1 (choose 0 10)
    choose'     <- choose 0 10
    chooseInt'  <- chooseInt 0 10
    collectAll' <- collectAll mempty (allInArray [0, 1, 2])
    allInArray' <- collectAll mempty (allInArray [0, 1, 2])
    allInRange' <- collectAll mempty (allInRange 0 10)
    dropGen'    <- collectAll mempty $ dropGen 2 (allInArray [2, 1, -1])
    takeGen'    <- collectAll mempty $ takeGen 2 (allInArray [2, 1, -1])
    elements'   <- arrayOf $ elements "foo" ["bar", "baz"]
    extend'     <- collectAll mempty $ extend 3 (pure "5")
    infinite'   <- collectAll mempty $ takeGen 4 (infinite $ pure "foo")
    return $ Mega {
      arrayOf:    arrayOf',
      arrayOf1:   (case arrayOf1' of Tuple a as -> a : as),
      choose:     choose',
      chooseInt:  chooseInt',
      collectAll: collectAll',
      allInArray: allInArray',
      allInRange: allInRange',
      dropGen:    dropGen',
      takeGen:    takeGen',
      elements:   elements',
      extend:     extend',
      infinite:   infinite' }

verify_gen :: Mega -> Result
verify_gen (Mega m) = fold [
  all (between 0 10) m.arrayOf                        <?> "arrayOf: "     ++ show m.arrayOf,
  Array.length m.arrayOf1 >= 1                        <?> "arrayOf1: "    ++ show m.arrayOf1,
  between 0 10 m.choose                               <?> "choose: "      ++ show m.choose,
  between 0 10 m.chooseInt &&
  Math.floor(m.chooseInt) == m.chooseInt              <?> "chooseInt: "   ++ show m.chooseInt,
  m.collectAll == [0, 1, 2]                           <?> "collectAll: "  ++ show m.collectAll,
  m.allInArray == [0, 1, 2]                           <?> "allInArray: "  ++ show m.allInArray,
  m.allInRange == [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]  <?> "allInRange: "  ++ show m.allInRange,
  m.dropGen == [-1]                                   <?> "dropGen: "     ++ show m.dropGen,
  m.takeGen == [2, 1]                                 <?> "takeGen: "     ++ show m.takeGen,
  all (flip elem ["foo", "bar", "baz"]) m.elements    <?> "elements: "    ++ show m.elements,
  m.extend == ["5", "5", "5"]                         <?> "extend: "      ++ show m.extend,
  m.infinite == ["foo", "foo", "foo", "foo"]          <?> "infinite: "    ++ show m.infinite ]

main = do
  trace "Gen combinators"
  quickCheck $ verify_gen

  trace "foldGen"
  quickCheck $ (runTrampoline $ foldGen (\a b -> Just $ a + b) 1 mempty (allInArray [1, 2, 3])) == 7

  trace "smallCheck"
  smallCheck $ runDetABC >>> (flip elem ["A", "B", "C"])

  trace "Fair distribution of booleans"
  statCheck (1/2) $ (==) true

  trace "Fair distribution of ints"
  statCheck (1/11) $ runOneToTen >>> ((==) 1)

module PreludeTests where

import Control.Monad.Eff
import Data.Eq
import Debug.Trace
import Test.QuickCheck
import Test.QuickCheck.LCG
import Control.Monad.Trampoline
import Data.Monoid
import Data.Tuple
import Data.Maybe
import Data.Foldable
import qualified Data.Array as Array
import qualified Math as Math

between :: forall a. (Ord a) => a -> a -> a -> Boolean
between min max = \n -> n >= min && n <= max

data Mega  = Mega {
  arrayOf     :: [Number],
  arrayOf1    :: [Number],
  choose      :: Number,
  chooseInt   :: Number,
  collectAll  :: [Number],
  allInArray  :: [Number],
  allInRange  :: [Number],
  dropGen     :: [Number],
  takeGen     :: [Number],
  elements    :: [String],
  extend      :: [String],
  infinite    :: [String] }

{- TODO: Remaining cases
  , frequency
  , oneOf
  , perturbGen
  , repeatable
  , resize
  , sample
  , sample'
  , showSample
  , showSample'
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , unfoldGen
  , uniform
  , variant
  , vectorOf
  -}

data OneToTen = OneToTen Number

runOneToTen :: OneToTen -> Number
runOneToTen (OneToTen n) = n

instance arbOneToTen :: Arbitrary OneToTen where
  arbitrary = OneToTen <$> chooseInt 0 10

instance arbMega :: Arbitrary Mega where
  arbitrary = do
    arrayOf'    <- arrayOf (choose 0 10)
    arrayOf1'   <- arrayOf1 (choose 0 10)
    choose'     <- choose 0 10
    chooseInt'  <- chooseInt 0 10
    collectAll' <- collectAll mempty (allInArray [0, 1, 2])
    allInArray' <- collectAll mempty (allInArray [0, 1, 2])
    allInRange' <- collectAll mempty (allInRange 0 10)
    dropGen'    <- collectAll mempty $ dropGen 2 (allInArray [2, 1, -1])
    takeGen'    <- collectAll mempty $ takeGen 2 (allInArray [2, 1, -1])
    elements'   <- arrayOf $ elements "foo" ["bar", "baz"]
    extend'     <- collectAll mempty $ extend 3 (pure "5")
    infinite'   <- collectAll mempty $ takeGen 4 (infinite $ pure "foo")
    return $ Mega {
      arrayOf:    arrayOf',
      arrayOf1:   (case arrayOf1' of Tuple a as -> a : as),
      choose:     choose',
      chooseInt:  chooseInt',
      collectAll: collectAll',
      allInArray: allInArray',
      allInRange: allInRange',
      dropGen:    dropGen',
      takeGen:    takeGen',
      elements:   elements',
      extend:     extend',
      infinite:   infinite' }

verify_gen :: Mega -> Result
verify_gen (Mega m) = fold [
  all (between 0 10) m.arrayOf                        <?> "arrayOf: "     ++ show m.arrayOf,
  Array.length m.arrayOf1 >= 1                        <?> "arrayOf1: "    ++ show m.arrayOf1,
  between 0 10 m.choose                               <?> "choose: "      ++ show m.choose,
  between 0 10 m.chooseInt &&
  Math.floor(m.chooseInt) == m.chooseInt              <?> "chooseInt: "   ++ show m.chooseInt,
  m.collectAll == [0, 1, 2]                           <?> "collectAll: "  ++ show m.collectAll,
  m.allInArray == [0, 1, 2]                           <?> "allInArray: "  ++ show m.allInArray,
  m.allInRange == [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]  <?> "allInRange: "  ++ show m.allInRange,
  m.dropGen == [-1]                                   <?> "dropGen: "     ++ show m.dropGen,
  m.takeGen == [2, 1]                                 <?> "takeGen: "     ++ show m.takeGen,
  all (flip elem ["foo", "bar", "baz"]) m.elements    <?> "elements: "    ++ show m.elements,
  m.extend == ["5", "5", "5"]                         <?> "extend: "      ++ show m.extend,
  m.infinite == ["foo", "foo", "foo", "foo"]          <?> "infinite: "    ++ show m.infinite ]

main = do
  trace "Gen combinators"
  quickCheck $ verify_gen

  trace "foldGen"
  quickCheck $ (runTrampoline $ foldGen (\a b -> Just $ a + b) 1 mempty (allInArray [1, 2, 3])) == 7

  trace "Fair distribution of booleans"
  statCheck (1/2) $ (==) true

  trace "Fair distribution of ints"
  statCheck (1/11) $ runOneToTen >>> ((==) 1)


Add (hacky) label for sig. level ruler

Add (hacky) label for sig. level ruler

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (red)
import Data.Array ((..))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum, minimum)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', view, (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Number.Format as Num
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy))
import Data.Tuple (Tuple(..), snd, uncurry)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Types (Bp, ChrId)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, aroundPair, pairSize, pairsOverlap, scaledSegments)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, FillStyle, OutlineStyle, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math (pow)
import Math as Math
import Type.Prelude (class RowLacks)

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

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

_batch = (SProxy :: SProxy "batch")
_single = (SProxy :: SProxy "single")

type Feature a = { position  :: Pair Bp
                 , frameSize :: Bp
                 , feature   :: a }

-- The very basic shapes a glyph can consist of (for now)
data GlyphShape
  = GCircle Number
  | GRect Number Number
  | GMany (List GlyphShape)

-- A `GlyphDrawing` is a shape plus styles informing how to render it (from purescript-drawing)
data GlyphDrawing
  = GDrawing OutlineStyle FillStyle GlyphShape

type NPoint = { x :: Normalized Number
              , y :: Normalized Number }

type DrawingR  = ( point :: Drawing
                 , range :: Number
                         -> { drawing :: Unit -> Drawing
                            , width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

type OldRenderer a = Variant ( batch :: BatchRenderer a
                             , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> Canvas.Dimensions
              -> Drawing
horRulerTrack {min, max, sig} color f = outlined outline rulerDrawing <> label
  where normY = (sig - min) / (max - min)
        thickness = 2.0
        outline = outlineColor color <> lineWidth thickness
        y = thickness + f.height - (normY * f.height)
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

        expSig = 10.0 `pow` (-sig)
        text  = "P = " <> (Num.toStringWith (Num.exponential 1) expSig)

        font' = font sansSerif 16 mempty
        label = Drawing.text font' (f.width+4.0) (y-6.0) (fillColor red) text

chrLabelTrack :: CoordSys ChrId BigInt
              -> Canvas.Dimensions
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack cs cdim =
  let font' = font sansSerif 12 mempty

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

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj _point $ chrText chr
                    , horPos:  inj _point $ Normalized (0.5)
                    , verPos: Normalized (0.03) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

chrLabelTrack' :: UISlot
               -> Map ChrId (Pair Number)
               -> Tuple UISlot (Array DrawingN)
chrLabelTrack' slot segs =
  let font' = font sansSerif 12 mempty

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

      y = slot.offset.y - (0.5 * slot.size.height)

      label :: ChrId -> Pair Number -> Array DrawingN
      label chr seg@(Pair l _) =
        let drawing = chrText chr
            point = { x: slot.offset.x + l + (pairSize seg) * 0.5, y }
        in [{ drawing, points: [point] }]

  in Tuple slot (foldMapWithIndex label segs)

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number i o
             => RowLacks l i
             => IsSymbol l
             => Getter' (Feature (Record a)) Number
             -> SProxy l
             -> Bp
             -> f (Feature (Record a))
             -> f (Feature (Record i))
             -> f (Feature (Record o))
bumpFeatures f l radius other = map bump
  where minInRadius :: Pair Bp -> Number
        minInRadius lr = fromMaybe 1.0
                         $ minimum
                          $ map (\g -> if pairsOverlap g.position lr
                                          then f `view` g else 1.0) other

        bump :: Feature (Record i) -> Feature (Record o)
        bump a =
          let y = minInRadius (aroundPair radius a.position)
          in { position: a.position
             , frameSize: a.frameSize
             , feature: Record.insert l y a.feature }

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Number
              , color :: Color
              | VScaleRow () }

negLog10 :: Number -> Number
negLog10 p = - ((Math.log p) / Math.ln10)

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  let
      hPad = vscale.width  / 8.0
      x = 7.0 * hPad

      numSteps = 3
      spokes = (_ / (Int.toNumber numSteps))
               <<< Int.toNumber <$> (0 .. numSteps)

      barOutline = outlineColor vscale.color <> lineWidth 2.0

      vBar = Drawing.path [{x, y: 0.0}, {x, y: height}]

      hBar w y = Drawing.path [{x:x-w, y}, {x, y}]
      bars = vBar
          <> foldMap (\i -> hBar 8.0 (i * height)) spokes

      unitLabel =
        Drawing.translate (vscale.width * 0.5 - hPad) (height * 0.72)
        $ Drawing.rotate (- Math.pi / 2.0)
        $ Drawing.text (font sansSerif 18 mempty)
            0.0 0.0 (fillColor black) "-log10 (P value)"

      label yN = Drawing.text
                    (font sansSerif 14 mempty)
                    (vscale.width * 0.6 - hPad)
                    (yN * height + 5.0)
                    (fillColor black)
                 $ Num.toStringWith (Num.fixed 0)
                 $ (\p -> min vscale.max p)
                 $ vscale.min + (1.0 - yN) * (vscale.max - vscale.min)

      labels = foldMap label spokes

  in outlined barOutline bars <> labels <> unitLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Number
              , entries :: Array LegendEntry }

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

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

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

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = { screenWidth: cdim.width
              , viewWidth: pairSize bView }
  in flip foldMapWithIndex (scaledSegments cs scale)

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

--------------------------

type DrawingN = { drawing :: Drawing, points :: Array Point }
type Label = { text :: String, point :: Point }

type RenderedTrack a = { features :: Array a
                       , drawings :: Array DrawingN
                       , labels   :: Array Label
                       , overlaps :: Number -> Point -> Array a }

type Renderer a =
     Canvas.Dimensions
  -> Map ChrId (Array a)
  -> Map ChrId (Pair Number)
  -> { features :: Array a
     , drawings :: Array DrawingN
     , labels   :: Array Label
     , overlaps :: Number -> Point -> Array a }

browser :: forall a b c.
           CoordSys ChrId BigInt
        -> Canvas.Dimensions
        -> Canvas.Dimensions
        -> UISlots
        -> { legend :: Legend, vscale :: VScale }
        -> { gwas        :: Renderer a
           , annotations :: Renderer b }
        -> { gwas        :: Map ChrId (Array a)
           , annotations :: Map ChrId (Array b) }
        -> { tracks     :: Pair BigInt
                        -> { gwas :: RenderedTrack a
                           , annotations :: RenderedTrack b }
           , relativeUI :: Pair BigInt -> Drawing
           , fixedUI    :: Drawing }
browser cs trackDim overlayDim uiSlots ui renderers inputTracks =
  let
      drawInSlot {offset, size} d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d

      vScale = drawInSlot uiSlots.left
                 $ drawVScale ui.vscale uiSlots.left.size.height
      legend = drawInSlot uiSlots.right
                 $ drawLegend ui.legend uiSlots.right.size.height

      ruler   = Drawing.translate ui.vscale.width uiSlots.top.size.height
                $ horRulerTrack ui.vscale red trackDim

      fixedUI = vScale <> legend <> ruler

      segmentPadding = 12.0

      segmentPixels vw =
        aroundPair (-segmentPadding)
        <$> scaledSegments cs
            { screenWidth: trackDim.width, viewWidth: pairSize vw }

      tracks =
        let gwasT  = renderers.gwas trackDim inputTracks.gwas
            annotT = renderers.annotations trackDim inputTracks.annotations
        in \v -> let segs = segmentPixels v
                 in { gwas: gwasT segs
                    , annotations: annotT segs }

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs overlayDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cs trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

      chrLabels :: _
      chrLabels = renderUIElement $ chrLabelTrack cs trackDim

      relativeUI :: Pair BigInt -> Drawing
      relativeUI v = drawTrackUI v chrLabels

  in { tracks
     , relativeUI
     , fixedUI
     }

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (red)
import Data.Array ((..))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum, minimum)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', view, (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Number.Format as Num
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy))
import Data.Tuple (Tuple(..), snd, uncurry)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Types (Bp, ChrId)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, aroundPair, pairSize, pairsOverlap, scaledSegments)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, FillStyle, OutlineStyle, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Type.Prelude (class RowLacks)

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

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

_batch = (SProxy :: SProxy "batch")
_single = (SProxy :: SProxy "single")

type Feature a = { position  :: Pair Bp
                 , frameSize :: Bp
                 , feature   :: a }

-- The very basic shapes a glyph can consist of (for now)
data GlyphShape
  = GCircle Number
  | GRect Number Number
  | GMany (List GlyphShape)

-- A `GlyphDrawing` is a shape plus styles informing how to render it (from purescript-drawing)
data GlyphDrawing
  = GDrawing OutlineStyle FillStyle GlyphShape

type NPoint = { x :: Normalized Number
              , y :: Normalized Number }

type DrawingR  = ( point :: Drawing
                 , range :: Number
                         -> { drawing :: Unit -> Drawing
                            , width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

type OldRenderer a = Variant ( batch :: BatchRenderer a
                             , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> Canvas.Dimensions
              -> Drawing
horRulerTrack {min, max, sig} color f = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        thickness = 2.0
        outline = outlineColor color <> lineWidth thickness
        y = thickness + f.height - (normY * f.height)
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BigInt
              -> Canvas.Dimensions
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack cs cdim =
  let font' = font sansSerif 12 mempty

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

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj _point $ chrText chr
                    , horPos:  inj _point $ Normalized (0.5)
                    , verPos: Normalized (0.03) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

chrLabelTrack' :: UISlot
               -> Map ChrId (Pair Number)
               -> Tuple UISlot (Array DrawingN)
chrLabelTrack' slot segs =
  let font' = font sansSerif 12 mempty

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

      y = slot.offset.y - (0.5 * slot.size.height)

      label :: ChrId -> Pair Number -> Array DrawingN
      label chr seg@(Pair l _) =
        let drawing = chrText chr
            point = { x: slot.offset.x + l + (pairSize seg) * 0.5, y }
        in [{ drawing, points: [point] }]

  in Tuple slot (foldMapWithIndex label segs)

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number i o
             => RowLacks l i
             => IsSymbol l
             => Getter' (Feature (Record a)) Number
             -> SProxy l
             -> Bp
             -> f (Feature (Record a))
             -> f (Feature (Record i))
             -> f (Feature (Record o))
bumpFeatures f l radius other = map bump
  where minInRadius :: Pair Bp -> Number
        minInRadius lr = fromMaybe 1.0
                         $ minimum
                          $ map (\g -> if pairsOverlap g.position lr
                                          then f `view` g else 1.0) other

        bump :: Feature (Record i) -> Feature (Record o)
        bump a =
          let y = minInRadius (aroundPair radius a.position)
          in { position: a.position
             , frameSize: a.frameSize
             , feature: Record.insert l y a.feature }

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Number
              , color :: Color
              | VScaleRow () }

negLog10 :: Number -> Number
negLog10 p = - ((Math.log p) / Math.ln10)

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  let
      hPad = vscale.width  / 8.0
      x = 7.0 * hPad

      numSteps = 3
      spokes = (_ / (Int.toNumber numSteps))
               <<< Int.toNumber <$> (0 .. numSteps)

      barOutline = outlineColor vscale.color <> lineWidth 2.0

      vBar = Drawing.path [{x, y: 0.0}, {x, y: height}]

      hBar w y = Drawing.path [{x:x-w, y}, {x, y}]
      bars = vBar
          <> foldMap (\i -> hBar 8.0 (i * height)) spokes

      unitLabel =
        Drawing.translate (vscale.width * 0.5 - hPad) (height * 0.72)
        $ Drawing.rotate (- Math.pi / 2.0)
        $ Drawing.text (font sansSerif 18 mempty)
            0.0 0.0 (fillColor black) "-log10 (P value)"

      label yN = Drawing.text
                    (font sansSerif 14 mempty)
                    (vscale.width * 0.6 - hPad)
                    (yN * height + 5.0)
                    (fillColor black)
                 $ Num.toStringWith (Num.fixed 0)
                 $ (\p -> min vscale.max p)
                 $ vscale.min + (1.0 - yN) * (vscale.max - vscale.min)

      labels = foldMap label spokes

  in outlined barOutline bars <> labels <> unitLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Number
              , entries :: Array LegendEntry }

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

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

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

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = { screenWidth: cdim.width
              , viewWidth: pairSize bView }
  in flip foldMapWithIndex (scaledSegments cs scale)

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

--------------------------

type DrawingN = { drawing :: Drawing, points :: Array Point }
type Label = { text :: String, point :: Point }

type RenderedTrack a = { features :: Array a
                       , drawings :: Array DrawingN
                       , labels   :: Array Label
                       , overlaps :: Number -> Point -> Array a }

type Renderer a =
     Canvas.Dimensions
  -> Map ChrId (Array a)
  -> Map ChrId (Pair Number)
  -> { features :: Array a
     , drawings :: Array DrawingN
     , labels   :: Array Label
     , overlaps :: Number -> Point -> Array a }

browser :: forall a b c.
           CoordSys ChrId BigInt
        -> Canvas.Dimensions
        -> Canvas.Dimensions
        -> UISlots
        -> { legend :: Legend, vscale :: VScale }
        -> { gwas        :: Renderer a
           , annotations :: Renderer b }
        -> { gwas        :: Map ChrId (Array a)
           , annotations :: Map ChrId (Array b) }
        -> { tracks     :: Pair BigInt
                        -> { gwas :: RenderedTrack a
                           , annotations :: RenderedTrack b }
           , relativeUI :: Pair BigInt -> Drawing
           , fixedUI    :: Drawing }
browser cs trackDim overlayDim uiSlots ui renderers inputTracks =
  let
      drawInSlot {offset, size} d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d

      vScale = drawInSlot uiSlots.left
                 $ drawVScale ui.vscale uiSlots.left.size.height
      legend = drawInSlot uiSlots.right
                 $ drawLegend ui.legend uiSlots.right.size.height

      ruler   = Drawing.translate ui.vscale.width uiSlots.top.size.height
                $ horRulerTrack ui.vscale red trackDim

      fixedUI = ruler <> vScale <> legend

      segmentPadding = 12.0

      segmentPixels vw =
        aroundPair (-segmentPadding)
        <$> scaledSegments cs
            { screenWidth: trackDim.width, viewWidth: pairSize vw }

      tracks =
        let gwasT  = renderers.gwas trackDim inputTracks.gwas
            annotT = renderers.annotations trackDim inputTracks.annotations
        in \v -> let segs = segmentPixels v
                 in { gwas: gwasT segs
                    , annotations: annotT segs }

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs overlayDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cs trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

      chrLabels :: _
      chrLabels = renderUIElement $ chrLabelTrack cs trackDim

      relativeUI :: Pair BigInt -> Drawing
      relativeUI v = drawTrackUI v chrLabels

  in { tracks
     , relativeUI
     , fixedUI
     }


Workaround to ensure detach handler runs

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

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, forkAll, runAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Either (Either(..))
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_, traverse_, sequence_)
import Data.Tuple (Tuple(..))

import Halogen (HalogenIO)
import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.EventSource as ES

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  forkAll finalizers
  -- No need to par/fork initializers here as there's only ever zero or one at
  -- this point, due to the squashing at each level of the component hierarchy.
  sequence_ initializers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component = do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs -> do
    listeners <- liftEff $ newRef M.empty
    runComponent (rootHandler listeners) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        pure
          { query: evalF st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    void $ forkAll $ map (\var -> AV.putVar var message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ forkAff do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar inputVar (error "ended")

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AV.AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \c -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState c componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    squashChildInitializers lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenF s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f -> do
      DriverState (st@{ state }) <- AV.takeVar ref
      case f state of
        Tuple a state' -> do
          AV.putVar ref (DriverState (st { state = state' }))
          handleLifecycle \lchs -> render lchs ref
          pure a
    Subscribe es next -> do
      forkAff do
        { producer, done } <- ES.unEventSource es
        var <- AV.makeVar
        let
          consumeES :: CR.Consumer (f' Boolean) (Aff (HalogenEffects eff)) Unit
          consumeES = flip tailRecM unit \_ -> do
            b <- lift <<< evalF ref =<< CR.await
            lift $ AV.putVar var (Left b)
            pure if b then Loop unit else Done unit
          consumeVar :: CR.Consumer Boolean (Aff (HalogenEffects eff)) Unit
          consumeVar = flip tailRecM unit \_ ->
            CR.await >>= case _ of
              false -> lift $ AV.putVar var (Right unit) $> Done unit
              true -> pure (Loop unit)
        forkAff $ CR.runProcess $ producer $$ consumeES
        CR.runProcess $ CR.producer (AV.takeVar var) $$ consumeVar
        done
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- AV.takeVar ref
      case pendingOut of
        Nothing -> do
          AV.putVar ref (DriverState ds)
          handler o
        Just p ->
          AV.putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = AV.takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    AV.putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- AV.takeVar var
    case pendingIn of
      Nothing -> do
        AV.putVar var (DriverState ds)
        handler message
      Just p ->
        AV.putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  squashChildInitializers
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  squashChildInitializers ref =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <$> st.component.initializer
      liftEff $ modifyRef ref \lchs ->
        { initializers: pure $ do
            parSequence_ (L.reverse lchs.initializers)
            sequence_ parentInitializer
            handlePending st.selfRef
        , finalizers: lchs.finalizers
        }

  handlePending
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- AV.takeVar ref
    AV.putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (forkAll <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- AV.takeVar ref
    AV.putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (forkAll <<< map handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AV.AVar a -> Aff (avar :: AV.AVAR | eff) a
peekVar v = do
  a <- AV.takeVar v
  AV.putVar v a
  pure a

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

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, forkAff, forkAll, runAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Either (Either(..))
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_, traverse_, sequence_)
import Data.Tuple (Tuple(..))

import Halogen (HalogenIO)
import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.EventSource as ES

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  forkAll finalizers
  -- No need to par/fork initializers here as there's only ever zero or one at
  -- this point, due to the squashing at each level of the component hierarchy.
  sequence_ initializers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component = do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs -> do
    listeners <- liftEff $ newRef M.empty
    runComponent (rootHandler listeners) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        pure
          { query: evalF st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    void $ forkAll $ map (\var -> AV.putVar var message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ forkAff do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar inputVar (error "ended")

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AV.AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \c -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState c componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    squashChildInitializers lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenF s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f -> do
      DriverState (st@{ state }) <- AV.takeVar ref
      case f state of
        Tuple a state' -> do
          AV.putVar ref (DriverState (st { state = state' }))
          handleLifecycle \lchs -> render lchs ref
          pure a
    Subscribe es next -> do
      forkAff do
        { producer, done } <- ES.unEventSource es
        let
          consumer = tailRecM loop unit
          loop _ = do
            continue <- lift <<< evalF ref =<< CR.await
            pure if continue then Loop unit else Done unit
        CR.runProcess (producer $$ consumer)
        done
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- AV.takeVar ref
      case pendingOut of
        Nothing -> do
          AV.putVar ref (DriverState ds)
          handler o
        Just p ->
          AV.putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = AV.takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    AV.putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- AV.takeVar var
    case pendingIn of
      Nothing -> do
        AV.putVar var (DriverState ds)
        handler message
      Just p ->
        AV.putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AV.AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  squashChildInitializers
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  squashChildInitializers ref =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <$> st.component.initializer
      liftEff $ modifyRef ref \lchs ->
        { initializers: pure $ do
            parSequence_ (L.reverse lchs.initializers)
            sequence_ parentInitializer
            handlePending st.selfRef
        , finalizers: lchs.finalizers
        }

  handlePending
    :: forall s f' g p o'
     . AV.AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- AV.takeVar ref
    AV.putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (forkAll <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- AV.takeVar ref
    AV.putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (forkAll <<< map handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AV.AVar a -> Aff (avar :: AV.AVAR | eff) a
peekVar v = do
  a <- AV.takeVar v
  AV.putVar v a
  pure a


minor refactor

minor refactor

module Main where

import Prelude

import Control.Monad.Aff (attempt)
import Control.Monad.Aff.Console (logShow)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (error)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (decodeJson)
import Data.Array ((..))
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite as T

data Action = RootDidMount

type Story = { title :: String }

type State = { topStories :: Array Story
             , topStoryIds :: Array Int }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)
            , topStoryIds: []
            }

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  eitherRes <- getTopStories
  let eitherIds = eitherRes >>= (_.response >>> decodeJson >>> lmap error)
  lift $ logShow eitherIds
  case eitherIds of
    Right ids -> void $ T.modifyState \s -> s { topStoryIds = ids }
    Left error -> pure unit

  where getTopStories =
          lift $ attempt $ Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList <<< map genFakeStory $ state.topStoryIds
  ]

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = T.simpleSpec performAction render

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"

module Main where

import Prelude

import Control.Monad.Aff (attempt)
import Control.Monad.Aff.Console (logShow)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (error)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (decodeJson)
import Data.Array ((..))
import Data.Bifunctor (lmap)
import Data.Either (either)
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite as T

data Action = RootDidMount

type Story = { title :: String }

type State = { topStories :: Array Story
             , topStoryIds :: Array Int }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)
            , topStoryIds: []
            }

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  eitherRes <- getTopStories
  let eitherIds = eitherRes >>= (_.response >>> decodeJson >>> lmap error)
  lift $ logShow eitherIds
  void $ T.modifyState \s -> s { topStoryIds = either (const []) id eitherIds }

  where getTopStories =
          lift $ attempt $ Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList <<< map genFakeStory $ state.topStoryIds
  ]

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = T.simpleSpec performAction render

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"


Rename to fromCategory

Rename to fromCategory

module Main where

import Prelude (Unit, (+), ($))
import Control.Monad.Eff (Eff)
import Projections (Projection, when, whenAny, runProjection, fromAll, fromStream, forEachInCategory, fromStreams)

-- Example state type
type State = {count :: Int}

type TypA = {event :: String}

handlerA :: State -> TypA -> State
handlerA s e = {count: s.count+1}

handlerB :: State -> TypA -> State
handlerB s e = {count: s.count+1}

fromAllProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromAllProjections = runProjection fromAll {count:0} $ when "$statsCollected" handlerA

fromStreamProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromStreamProjections = runProjection (fromStream "$stats-127.0.0.1:2113") {count:0} $ when "$statsCollected" handlerA

forEachInCategoryProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
forEachInCategoryProjections = runProjection (fromCategory "$stats") {count:0} $ when "$statsCollected" handlerA

fromStreamsProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromStreamsProjections = runProjection (fromStreams ["$stats-127.0.0.1:2113", "$projections-$master"]) {count:0} $ when "$statsCollected" handlerA

whenAnyEvent :: forall t. Eff (eventFold :: Projection | t) Unit
whenAnyEvent = runProjection fromAll {count:0} $ whenAny handlerA

main :: forall t9. Eff ( eventFold :: Projection | t9) Unit
main = whenAnyEvent

module Main where

import Prelude (Unit, (+), ($))
import Control.Monad.Eff (Eff)
import Projections (Projection, when, whenAny, runProjection, fromAll, fromStream, forEachInCategory, fromStreams)

-- Example state type
type State = {count :: Int}

type TypA = {event :: String}

handlerA :: State -> TypA -> State
handlerA s e = {count: s.count+1}

handlerB :: State -> TypA -> State
handlerB s e = {count: s.count+1}

fromAllProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromAllProjections = runProjection fromAll {count:0} $ when "$statsCollected" handlerA

fromStreamProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromStreamProjections = runProjection (fromStream "$stats-127.0.0.1:2113") {count:0} $ when "$statsCollected" handlerA

forEachInCategoryProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
forEachInCategoryProjections = runProjection (forEachInCategory "$stats") {count:0} $ when "$statsCollected" handlerA

fromStreamsProjections :: forall t9. Eff ( eventFold :: Projection | t9) Unit
fromStreamsProjections = runProjection (fromStreams ["$stats-127.0.0.1:2113", "$projections-$master"]) {count:0} $ when "$statsCollected" handlerA

whenAnyEvent :: forall t. Eff (eventFold :: Projection | t) Unit
whenAnyEvent = runProjection fromAll {count:0} $ whenAny handlerA

main :: forall t9. Eff ( eventFold :: Projection | t9) Unit
main = whenAnyEvent


Patch node' instead of node

Patch node' instead of node

-- | The main module of the Halogen library. It defines functions for running applications
-- | assembled from the parts defined in the various submodules:
-- |
-- | - `Halogen.Signal` for responding to inputs and maintaining state
-- | - `Halogen.HTML.*` for templating HTML documents
-- | - `Halogen.Component` for building application components
-- | - `Halogen.Themes.*` for rendering using common front-end libraries
-- | - `Halogen.Mixin.*` for common additional application features
-- |
-- | The functionality of this library is completely described by the type signature of the `runUI`
-- | function, which renders a `Component` to the DOM. The other modules exist to make the construction
-- | of `Component`s as simple as possible.
-- |
module Halogen
  ( HalogenEffects()
  , Driver()
  , Process()

  , changes

  , runUI
  , runUIWith

  , componentProcess
  , mainLoop
  ) where

import DOM
import Data.DOM.Simple.Types

import Data.Maybe
import Data.Tuple
import Data.Either

import Data.Profunctor.Strong ((&&&), (***))

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Exception

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Renderer.VirtualDOM as R

import Halogen.Signal
import Halogen.Component
import Halogen.HTML.Events.Monad
import Halogen.Internal.VirtualDOM (VTree(), Patch(), diff, patch, createElement)

-- | Wraps the effects required by the `runUI` function.
type HalogenEffects eff = (trace :: Trace, ref :: Ref, dom :: DOM | eff)

-- | A signal which emits patches corresponding to successive `VTree`s.
-- |
-- | This function can be used to create alternative top-level handlers which use `virtual-dom`.
changes :: VTree -> SF VTree Patch
changes = differencesWith diff

-- | This type synonym is provided to tidy up the type signature of `runUI`.
-- |
-- | The _driver function_ can be used by the caller to inject additional inputs into the system at the top-level.
-- |
-- | This is useful for supporting applications which respond to external events which originate
-- | outside the UI, such as timers or hash-change events.
-- |
-- | For example, to drive the UI with a `Tick` input every second, we might write something like the following:
-- |
-- | ```purescript
-- | main = do
-- |   Tuple node driver <- runUI ui
-- |   appendToBody node
-- |   setInterval 1000 $ driver Tick
-- | ```
type Driver i eff = i -> Eff (HalogenEffects eff) Unit

-- | `runUI` renders a `Component` to the DOM using `virtual-dom`.
-- |
-- | This function is the workhorse of the Halogen library. It can be called in `main`
-- | to set up the application and create the driver function, which can be used to
-- | send inputs to the UI from external components.
runUI :: forall req eff.
           Component (Event (HalogenEffects eff)) req req ->
           Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI sf = sf `runUIWith` \_ _ _ -> return unit

-- | A variant of `runUI` which supports a _post-render hook_. This allows applications
-- | to support third-party components or other custom behaviors by modifying the DOM after
-- | each update.
-- |
-- | This is considered an advanced feature, and should only be used with an understanding of
-- | the rendering pipeline.
runUIWith :: forall req eff.
               Component (Event (HalogenEffects eff)) req req ->
               (req -> HTMLElement -> Driver req eff -> Eff (HalogenEffects eff) Unit) ->
               Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUIWith sf postRender = mainLoop (pure <<< componentProcess sf postRender)

-- | A `Process` receives inputs and outputs effectful computations which update the DOM.
type Process req eff = SF (Tuple req HTMLElement) (Eff (HalogenEffects eff) HTMLElement)

-- | Build a `Process` from a `Component`.
componentProcess :: forall req eff.
                      Component (Event (HalogenEffects eff)) req req ->
                      (req -> HTMLElement -> Driver req eff -> Eff (HalogenEffects eff) Unit) ->
                      Driver req eff ->
                      Tuple HTMLElement (Process req eff)
componentProcess sf postRender driver =
  let render  = R.renderHTML requestHandler
      vtrees  = render <$> sf
      diffs   = tail vtrees >>> changes (head vtrees)
      process = (diffs &&& input) *** input
      node    = createElement (head vtrees)
  in Tuple node (applyPatch <$> process)
  where
  requestHandler :: Event (HalogenEffects eff) req -> Eff (HalogenEffects eff) Unit
  requestHandler aff = runEvent logger driver aff

  logger :: Error -> Eff (HalogenEffects eff) Unit
  logger e = trace $ "Uncaught error in asynchronous code: " <> message e

  applyPatch :: Tuple (Tuple Patch req) HTMLElement -> Eff (HalogenEffects eff) HTMLElement
  applyPatch (Tuple (Tuple p req) node) = do
    node' <- patch p node
    postRender req node' driver
    return node'

-- | This function provides the low-level implementation of Halogen's DOM update loop.
-- |
-- | The first argument is a function which receives the `Driver` function as an argument and
-- | constructs a `Process` which will update the DOM given an input.
-- |
-- | This function could be reused to create other types of applications based on signal functions
-- | (2D and 3D canvas, text-based, etc.)
mainLoop :: forall req eff. (Driver req eff -> Eff (HalogenEffects eff) (Tuple HTMLElement (Process req eff))) ->
                            Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
mainLoop buildProcess = do
  ref <- newRef Nothing
  go ref
  where
  go :: RefVal (Maybe { process :: Process req eff, node :: HTMLElement }) ->
        Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
  go ref = do
    Tuple node process <- buildProcess driver
    writeRef ref $ Just { process: process, node: node }
    return (Tuple node driver)
    where

    driver :: Driver req eff
    driver req = do
      ms <- readRef ref
      case ms of
        Just { process: process, node: node } -> do
          let work = runSF process (Tuple req node)
          node' <- head work
          writeRef ref $ Just { process: tail work, node: node' }
        Nothing -> trace "Error: An attempt to re-render was made during the initial render."

-- | The main module of the Halogen library. It defines functions for running applications
-- | assembled from the parts defined in the various submodules:
-- |
-- | - `Halogen.Signal` for responding to inputs and maintaining state
-- | - `Halogen.HTML.*` for templating HTML documents
-- | - `Halogen.Component` for building application components
-- | - `Halogen.Themes.*` for rendering using common front-end libraries
-- | - `Halogen.Mixin.*` for common additional application features
-- |
-- | The functionality of this library is completely described by the type signature of the `runUI`
-- | function, which renders a `Component` to the DOM. The other modules exist to make the construction
-- | of `Component`s as simple as possible.
-- |
module Halogen
  ( HalogenEffects()
  , Driver()
  , Process()

  , changes

  , runUI
  , runUIWith

  , componentProcess
  , mainLoop
  ) where

import DOM
import Data.DOM.Simple.Types

import Data.Maybe
import Data.Tuple
import Data.Either

import Data.Profunctor.Strong ((&&&), (***))

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Exception

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Renderer.VirtualDOM as R

import Halogen.Signal
import Halogen.Component
import Halogen.HTML.Events.Monad
import Halogen.Internal.VirtualDOM (VTree(), Patch(), diff, patch, createElement)

-- | Wraps the effects required by the `runUI` function.
type HalogenEffects eff = (trace :: Trace, ref :: Ref, dom :: DOM | eff)

-- | A signal which emits patches corresponding to successive `VTree`s.
-- |
-- | This function can be used to create alternative top-level handlers which use `virtual-dom`.
changes :: VTree -> SF VTree Patch
changes = differencesWith diff

-- | This type synonym is provided to tidy up the type signature of `runUI`.
-- |
-- | The _driver function_ can be used by the caller to inject additional inputs into the system at the top-level.
-- |
-- | This is useful for supporting applications which respond to external events which originate
-- | outside the UI, such as timers or hash-change events.
-- |
-- | For example, to drive the UI with a `Tick` input every second, we might write something like the following:
-- |
-- | ```purescript
-- | main = do
-- |   Tuple node driver <- runUI ui
-- |   appendToBody node
-- |   setInterval 1000 $ driver Tick
-- | ```
type Driver i eff = i -> Eff (HalogenEffects eff) Unit

-- | `runUI` renders a `Component` to the DOM using `virtual-dom`.
-- |
-- | This function is the workhorse of the Halogen library. It can be called in `main`
-- | to set up the application and create the driver function, which can be used to
-- | send inputs to the UI from external components.
runUI :: forall req eff.
           Component (Event (HalogenEffects eff)) req req ->
           Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI sf = sf `runUIWith` \_ _ _ -> return unit

-- | A variant of `runUI` which supports a _post-render hook_. This allows applications
-- | to support third-party components or other custom behaviors by modifying the DOM after
-- | each update.
-- |
-- | This is considered an advanced feature, and should only be used with an understanding of
-- | the rendering pipeline.
runUIWith :: forall req eff.
               Component (Event (HalogenEffects eff)) req req ->
               (req -> HTMLElement -> Driver req eff -> Eff (HalogenEffects eff) Unit) ->
               Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUIWith sf postRender = mainLoop (pure <<< componentProcess sf postRender)

-- | A `Process` receives inputs and outputs effectful computations which update the DOM.
type Process req eff = SF (Tuple req HTMLElement) (Eff (HalogenEffects eff) HTMLElement)

-- | Build a `Process` from a `Component`.
componentProcess :: forall req eff.
                      Component (Event (HalogenEffects eff)) req req ->
                      (req -> HTMLElement -> Driver req eff -> Eff (HalogenEffects eff) Unit) ->
                      Driver req eff ->
                      Tuple HTMLElement (Process req eff)
componentProcess sf postRender driver =
  let render  = R.renderHTML requestHandler
      vtrees  = render <$> sf
      diffs   = tail vtrees >>> changes (head vtrees)
      process = (diffs &&& input) *** input
      node    = createElement (head vtrees)
  in Tuple node (applyPatch <$> process)
  where
  requestHandler :: Event (HalogenEffects eff) req -> Eff (HalogenEffects eff) Unit
  requestHandler aff = runEvent logger driver aff

  logger :: Error -> Eff (HalogenEffects eff) Unit
  logger e = trace $ "Uncaught error in asynchronous code: " <> message e

  applyPatch :: Tuple (Tuple Patch req) HTMLElement -> Eff (HalogenEffects eff) HTMLElement
  applyPatch (Tuple (Tuple p req) node) = do
    node' <- patch p node
    postRender req node driver
    return node'

-- | This function provides the low-level implementation of Halogen's DOM update loop.
-- |
-- | The first argument is a function which receives the `Driver` function as an argument and
-- | constructs a `Process` which will update the DOM given an input.
-- |
-- | This function could be reused to create other types of applications based on signal functions
-- | (2D and 3D canvas, text-based, etc.)
mainLoop :: forall req eff. (Driver req eff -> Eff (HalogenEffects eff) (Tuple HTMLElement (Process req eff))) ->
                            Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
mainLoop buildProcess = do
  ref <- newRef Nothing
  go ref
  where
  go :: RefVal (Maybe { process :: Process req eff, node :: HTMLElement }) ->
        Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
  go ref = do
    Tuple node process <- buildProcess driver
    writeRef ref $ Just { process: process, node: node }
    return (Tuple node driver)
    where

    driver :: Driver req eff
    driver req = do
      ms <- readRef ref
      case ms of
        Just { process: process, node: node } -> do
          let work = runSF process (Tuple req node)
          node' <- head work
          writeRef ref $ Just { process: tail work, node: node' }
        Nothing -> trace "Error: An attempt to re-render was made during the initial render."


Added debug interpretation to WebGL monad.