Start on fixing renderers to take canvas/frame width into account

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
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 as Array
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum)
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.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Semigroup.Foldable (foldMap1)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse)
import Data.Tuple (Tuple(Tuple), fst, snd, uncurry)
import Data.Unfoldable (class Unfoldable, singleton)
import Data.Unfoldable as Unfoldable
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, 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 IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.

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

-- Drawings are not entirely pure. They can depend on the width of the
-- frame, if they something that spans across a range of the genome.
-- So, the `drawing` field should really have type
--   Pixels -> Drawing
-- where the `Pixels` is the width of the frame. Renderers already
-- have access to the chr size when created, so the width is all that's needed.
type PureRenderer' a = a -> Maybe { drawing :: Pixels -> Drawing
                                  , point   :: Normalized Point
                                  }

mkGeneRenderer' :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer' (Gene rf))
mkGeneRenderer' = do
  ctx <- ask

  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        let rad = 20.0
            lHand = unwrap $ f.start / size
            rHand = unwrap $ f.end / size
            w = (rHand - lHand) * unwrap size
            x = lHand + (rHand - lHand)
            y = 0.0
            rect = rectangle lHand (y - rad/2.0) w (rad/2.0)
            out = outlined (outlineColor red) rect
            fill = filled (fillColor maroon) rect
            -- 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 (y-0.25) (fillColor black) f.desc
            drawing = out <> fill <> text'

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

  pure $ unsafeCoerce unit

tagRenderer :: forall a sym r1 r2.
               RowCons sym a r1 r2
            => IsSymbol sym
            => SProxy sym
            -> PureRenderer a
            -> PureRenderer (Variant r2)
tagRenderer sym renderer var = Variant.prj sym var >>= renderer

combineRenderers :: forall r1 r2 r3.
                    Union r1 r2 r3
                 => Contractable r3 r1
                 => Contractable r3 r2
                 => PureRenderer (Variant r1)
                 -> PureRenderer (Variant r2)
                 -> PureRenderer (Variant r3)
combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
                             (Variant.contract var >>= r2)

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

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: 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

-- A single Frame that contains all data that is required to draw it
type ReadyFrame a = { width :: Pixels
                    , padding :: Pixels
                    , height :: Pixels
                    , contents :: a }

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

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o d -> translate o 0.0 d) os drawings'
  where os = Array.cons 0.0 (framesOffsets $ snd <$> frames) -- add 0.0 since scanl in framesOffsets doesn't include seed
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

createFrames :: forall r a.
                RowLacks "frame" (size :: Bp | r)
             => Pixels
             -> Pixels
             -> Map ChrId {size :: Bp | r}
             -> Map ChrId a
             -> Map ChrId { size :: Bp, frame :: Frame a | r }
createFrames totalWidth padding sizes as = zipMapsWith zippy sizes as
  where ts = totalSize sizes
        mkWidth size = (unwrap $ size / ts) * totalWidth
        mkFrame' {size} a = { padding, width: mkWidth size, contents: a }
        zippy r a = insertFrame (mkFrame' r a) r

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

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 :: { chrId :: ChrId | rData } -> Maybe _ -> Maybe _
        add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

chrFrames :: forall a.
             _
          -> Pixels
          -> Pixels
          -> Map ChrId a
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       }
chrFrames ctx w p as = createFrames w p chrCtx' as
  where chrCtx' = Map.filterKeys (\k -> k `Map.member` as) ctx

mouseChrFrames = chrFrames mouseChrCtx

addHeight :: forall a r.
             Pixels
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       | r
                       }
          -> Map ChrId { size :: Bp
                       , frame :: (ReadyFrame a)
                       | r }
addHeight h fs = map f fs
  where f entry = entry { frame = Record.insert (SProxy :: SProxy "height") h entry.frame }

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 | r )

type Gene' r = Record (GeneRow' r)

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

type Gene r = Record (GeneRow r)

gene'JSONParse :: Json -> Maybe (Gene' ())
gene'JSONParse 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
  pure {geneID, desc, name, start, end}

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}

fetchGene'JSON :: String -> Aff _ (Array (Gene' ()))
fetchGene'JSON = fetchJSON gene'JSONParse

geneFetchChrId :: forall r.
                  RowLacks "chrId" (GeneRow' r)
               => Gene' r
               -> Aff _ (Gene r)
geneFetchChrId gene = do
  let url = "http://rest.ensembl.org/lookup/id/" <>
            gene.geneID <> "?content-type=application/json"

  res <- _.response <$> Affjax.get url

  let chrId :: _
      chrId = do
        obj <- res ^? _Object
        ChrId <$> obj ^? ix "seq_region_name" <<< _String

  case chrId of
    Nothing  -> throwError $ error $ "Could not find chrId for gene " <> gene.geneID
    Just chr -> pure $ Record.insert (SProxy :: SProxy "chrId") chr gene

fetchGeneJSONEnsembl :: String -> Aff _ (Array (Gene ()))
fetchGeneJSONEnsembl url = traverse geneFetchChrId =<< fetchJSON gene'JSONParse url

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

mkGeneRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp | rctx)) m
               => m (PureRenderer (Gene rf))
mkGeneRenderer = do
  ctx <- ask

  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        let rad = 20.0
            lHand = unwrap $ f.start / size
            rHand = unwrap $ f.end / size
            w = (rHand - lHand)
            x = lHand + (rHand - lHand)
            y = 0.0
            rect = rectangle lHand (y - rad/2.0) w (rad/2.0)
            out = outlined (outlineColor red) rect
            fill = filled (fillColor maroon) rect
            -- 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 (y-0.25) (fillColor black) f.desc
            drawing = out <> fill <> text'

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

  pure renderer

{-
What is needed is a way to get the score for some other thing
at or close to the annotation.

Maybe we can use the `point` property of the renderers.
In fact, that is the only thing we need to modify.
However, modifying that becomes tricky -- where do we do it,
and how do we keep track of it so that it's reversible?

THIS IS HOW:
"Render" everything once, at start. Then just use those Drawings and Normalized Points
when the chr view changes, zooms, etc. For now we can assume that we can just wait
a few seconds at start; later we can show the mid-steps.
Using this data (plus some sort of Shape usable for collision detection and/or some
provided "bumping" rules) we can iterate the track until everything is where it
should be.
That could even use Event's `fix` function to show the bumping take place...

There's one problem -- the horizontal interval a glyph covers is
a function of the BpPerPixels scale. I.e. even though each feature is always
drawn using the same Drawing and Normalized Point, the /relative horizontal/
positioning of glyphs is a function of:

the Drawings, Normalized Points, Collision Shapes in the neighborhood, and
the /current/ BpPerPixels in the chromosome.

However, it should be a pretty basic function. Linear, even.

Anyway, this is going to be tricky enough to not attack as a first attempt;
get something that works with what we've got right now, first.
-}
shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: 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 = (s.max - f.minY) / (s.max - s.min)
      y' = min (normY - dist) 1.0

  Debug.trace (show f.minY) \_ -> pure unit
  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

bumpedGeneRenderer :: forall rf.
                      RowLacks "minY" (GeneRow rf)
                   => { min :: Number, max :: Number }
                   -> PureRenderer (Gene rf)
                   -> PureRenderer (Gene (minY :: Number | rf))
bumpedGeneRenderer s = shiftRendererMinY 0.05 s

bumpGenes :: forall rGene rGWAS.
             RowLacks "minY" (GeneRow rGene)
          => Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Gene rGene))
          -> Map ChrId (List (Gene (minY :: Number | rGene)))
bumpGenes = zipMapsWith (map <<< bumpGene)
  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
        bumpGene :: List (GWASFeature rGWAS) -> Gene rGene -> Gene (minY :: Number | rGene)
        bumpGene l g = let minY = maxScoreIn g.start g.end l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , genes :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , genes :: Map ChrId (List (Gene (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  genes' <- fetchGeneJSON urls.genes
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let genesChr :: Map ChrId (List (Gene ()))
      genesChr = List.fromFoldable <$> groupToChrs genes'
  let bumpedGenes :: Map ChrId (List (Gene (minY :: Number)))
      bumpedGenes = bumpGenes gwasChr genesChr

  pure { gwas: gwasChr, genes: bumpedGenes }

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

        genes :: PureRenderer (Gene (minY :: Number))
        genes = bumpedGeneRenderer s $ mkGeneRenderer mouseChrCtx

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { min :: Number, max :: Number }
         -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , genes :: Map ChrId (f (Gene (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo s f {gwas, genes} chrs = (drawData' f mouseChrCtx renderers.gwas gwas chrs) <>
                                  (drawData' f mouseChrCtx renderers.genes genes chrs)
  where renderers = renderersDemo s

{-
The only way _this_ function would work (without a ridiculous number
of type annotations, if then) would be if the `r` row contains *all*
intermediate types.

But then it could work. No idea if it's in any way reasonable
or useful even if it does work, tho :) :) :)

Actually, it might work kind of nice if Variant.onMatch is used.
Then we'd just have to provide a record where each field corresponds
to a function modifying the respective data depending on one of the
possible data types; the function would itself use Variant.onMatch
since each type of data should be able to interact with every other
type of data.
-}

pipeline :: forall r.
            List (List (Variant r) -> List (Variant r))
         -> Map ChrId (List (Variant r))
         -> Map ChrId (List (Variant r))
pipeline = unsafeCoerce unit

-- Draw data by rendering it only once
drawData' :: forall f a r.
             Foldable f
          => Filterable f
          -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
          => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
          -> Map ChrId { size :: Bp | r}
          -> PureRenderer a
          -> Map ChrId (f a)
          -> Array ChrId
          -> Drawing
drawData' frameBox chrCtx renderer dat chrs = translate 0.0 (frameBox.height - frameBox.yOffset)
                                                $ scale 1.0 (-1.0)
                                                $ drawPureFrames (frames chrs)
  -- TODO add a traceAny statement here to make sure it only runs once
  where drawings :: Map ChrId (f {drawing :: Drawing, point :: _})
        drawings = map (pureRender renderer) dat

        mkFrame :: Bp -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
        mkFrame total chr = do
          {size} <- Map.lookup chr chrCtx
          let width = (unwrap $ size / total) * frameBox.width
          pure { height: frameBox.height, padding: frameBox.padding, width }

        mkFrames :: Array ChrId -> Array { width :: _, height :: _, padding :: _ }
        mkFrames = filterMap (mkFrame $ totalSize chrCtx)

        frames :: Array ChrId -> Array (Tuple (Array _) (_))
        frames chrs' = Array.zip (filterMap (\c -> Array.fromFoldable <$> Map.lookup c drawings) chrs')
                                 (mkFrames chrs')
{-
drawGenes :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> List (Gene r)
          -> Array ChrId
          -> Drawing
drawGenes pos dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where renderer = mkGeneRenderer mouseChrCtx

drawGemma :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> { min :: Number, max :: Number }
          -> List (GWASFeature r)
          -> Array ChrId
          -> Drawing
drawGemma pos s dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer :: PureRenderer (GWASFeature r)
        renderer = mkGwasRenderer s colorsCtx

drawBoth :: forall r.
            { w :: Number, h :: Number
            , p :: Number, y :: Number }
         -> { min :: Number, max :: Number }
         -> Map ChrId (List (Variant ("Gene" :: Gene (), "GWAS" :: GWASFeature ())))
         -> Array ChrId
         -> Drawing
drawBoth pos s dat chrs = drawData pos renderer dat chrs
  where geneR :: PureRenderer (Variant ("Gene" :: Gene ()))
        geneR = tagRenderer (SProxy :: SProxy "Gene") $ mkGeneRenderer mouseChrCtx
        gemmaR :: PureRenderer (Variant ("GWAS" :: GWASFeature ()))
        gemmaR = tagRenderer (SProxy :: SProxy "GWAS") $ mkGwasRenderer s colorsCtx
        colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer = combineRenderers geneR gemmaR
-}

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 $ 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

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
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 as Array
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum)
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.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Semigroup.Foldable (foldMap1)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse)
import Data.Tuple (Tuple(Tuple), fst, snd, uncurry)
import Data.Unfoldable (class Unfoldable, singleton)
import Data.Unfoldable as Unfoldable
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, 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 IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

tagRenderer :: forall a sym r1 r2.
               RowCons sym a r1 r2
            => IsSymbol sym
            => SProxy sym
            -> PureRenderer a
            -> PureRenderer (Variant r2)
tagRenderer sym renderer var = Variant.prj sym var >>= renderer

combineRenderers :: forall r1 r2 r3.
                    Union r1 r2 r3
                 => Contractable r3 r1
                 => Contractable r3 r2
                 => PureRenderer (Variant r1)
                 -> PureRenderer (Variant r2)
                 -> PureRenderer (Variant r3)
combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
                             (Variant.contract var >>= r2)

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

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: 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

-- A single Frame that contains all data that is required to draw it
type ReadyFrame a = { width :: Pixels
                    , padding :: Pixels
                    , height :: Pixels
                    , contents :: a }

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

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o d -> translate o 0.0 d) os drawings'
  where os = Array.cons 0.0 (framesOffsets $ snd <$> frames) -- add 0.0 since scanl in framesOffsets doesn't include seed
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

createFrames :: forall r a.
                RowLacks "frame" (size :: Bp | r)
             => Pixels
             -> Pixels
             -> Map ChrId {size :: Bp | r}
             -> Map ChrId a
             -> Map ChrId { size :: Bp, frame :: Frame a | r }
createFrames totalWidth padding sizes as = zipMapsWith zippy sizes as
  where ts = totalSize sizes
        mkWidth size = (unwrap $ size / ts) * totalWidth
        mkFrame' {size} a = { padding, width: mkWidth size, contents: a }
        zippy r a = insertFrame (mkFrame' r a) r

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

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 :: { chrId :: ChrId | rData } -> Maybe _ -> Maybe _
        add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

chrFrames :: forall a.
             _
          -> Pixels
          -> Pixels
          -> Map ChrId a
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       }
chrFrames ctx w p as = createFrames w p chrCtx' as
  where chrCtx' = Map.filterKeys (\k -> k `Map.member` as) ctx

mouseChrFrames = chrFrames mouseChrCtx

addHeight :: forall a r.
             Pixels
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       | r
                       }
          -> Map ChrId { size :: Bp
                       , frame :: (ReadyFrame a)
                       | r }
addHeight h fs = map f fs
  where f entry = entry { frame = Record.insert (SProxy :: SProxy "height") h entry.frame }

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 | r )

type Gene' r = Record (GeneRow' r)

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

type Gene r = Record (GeneRow r)

gene'JSONParse :: Json -> Maybe (Gene' ())
gene'JSONParse 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
  pure {geneID, desc, name, start, end}

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}

fetchGene'JSON :: String -> Aff _ (Array (Gene' ()))
fetchGene'JSON = fetchJSON gene'JSONParse

geneFetchChrId :: forall r.
                  RowLacks "chrId" (GeneRow' r)
               => Gene' r
               -> Aff _ (Gene r)
geneFetchChrId gene = do
  let url = "http://rest.ensembl.org/lookup/id/" <>
            gene.geneID <> "?content-type=application/json"

  res <- _.response <$> Affjax.get url

  let chrId :: _
      chrId = do
        obj <- res ^? _Object
        ChrId <$> obj ^? ix "seq_region_name" <<< _String

  case chrId of
    Nothing  -> throwError $ error $ "Could not find chrId for gene " <> gene.geneID
    Just chr -> pure $ Record.insert (SProxy :: SProxy "chrId") chr gene

fetchGeneJSONEnsembl :: String -> Aff _ (Array (Gene ()))
fetchGeneJSONEnsembl url = traverse geneFetchChrId =<< fetchJSON gene'JSONParse url

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

mkGeneRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp | rctx)) m
               => m (PureRenderer (Gene rf))
mkGeneRenderer = do
  ctx <- ask

  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        let rad = 20.0
            lHand = unwrap $ f.start / size
            rHand = unwrap $ f.end / size
            w = (rHand - lHand) * unwrap size
            x = lHand + (rHand - lHand)
            y = 0.5
            rect = rectangle lHand (y - rad/2.0) w (rad/2.0)
            out = outlined (outlineColor red) rect
            fill = filled (fillColor maroon) rect
            -- 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 (y-0.25) (fillColor black) f.desc
            drawing = out <> fill <> text'

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

  pure renderer

{-
What is needed is a way to get the score for some other thing
at or close to the annotation.

Maybe we can use the `point` property of the renderers.
In fact, that is the only thing we need to modify.
However, modifying that becomes tricky -- where do we do it,
and how do we keep track of it so that it's reversible?

THIS IS HOW:
"Render" everything once, at start. Then just use those Drawings and Normalized Points
when the chr view changes, zooms, etc. For now we can assume that we can just wait
a few seconds at start; later we can show the mid-steps.
Using this data (plus some sort of Shape usable for collision detection and/or some
provided "bumping" rules) we can iterate the track until everything is where it
should be.
That could even use Event's `fix` function to show the bumping take place...

There's one problem -- the horizontal interval a glyph covers is
a function of the BpPerPixels scale. I.e. even though each feature is always
drawn using the same Drawing and Normalized Point, the /relative horizontal/
positioning of glyphs is a function of:

the Drawings, Normalized Points, Collision Shapes in the neighborhood, and
the /current/ BpPerPixels in the chromosome.

However, it should be a pretty basic function. Linear, even.

Anyway, this is going to be tricky enough to not attack as a first attempt;
get something that works with what we've got right now, first.
-}
shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: 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 = (s.max - f.minY) / (s.max - s.min)
      y' = min (y + normY - dist) 1.0
  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

bumpedGeneRenderer :: forall rf.
                      RowLacks "minY" (GeneRow rf)
                   => { min :: Number, max :: Number }
                   -> PureRenderer (Gene rf)
                   -> PureRenderer (Gene (minY :: Number | rf))
bumpedGeneRenderer s = shiftRendererMinY 0.05 s

bumpGenes :: forall rGene rGWAS.
             RowLacks "minY" (GeneRow rGene)
          => Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Gene rGene))
          -> Map ChrId (List (Gene (minY :: Number | rGene)))
bumpGenes = zipMapsWith (map <<< bumpGene)
  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
        bumpGene :: List (GWASFeature rGWAS) -> Gene rGene -> Gene (minY :: Number | rGene)
        bumpGene l g = let minY = maxScoreIn g.start g.end l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , genes :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , genes :: Map ChrId (List (Gene (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  genes' <- fetchGeneJSON urls.genes
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let genesChr :: Map ChrId (List (Gene ()))
      genesChr = List.fromFoldable <$> groupToChrs genes'
  let bumpedGenes :: Map ChrId (List (Gene (minY :: Number)))
      bumpedGenes = bumpGenes gwasChr genesChr

  pure { gwas: gwasChr, genes: bumpedGenes }

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

        genes :: PureRenderer (Gene (minY :: Number))
        genes = bumpedGeneRenderer s $ mkGeneRenderer mouseChrCtx

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { min :: Number, max :: Number }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , genes :: Map ChrId (f (Gene (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo f s {gwas, genes} chrs = (drawData' f mouseChrCtx renderers.gwas gwas chrs) <>
                                  (drawData' f mouseChrCtx renderers.genes genes chrs)
  where renderers = renderersDemo s

{-
The only way _this_ function would work (without a ridiculous number
of type annotations, if then) would be if the `r` row contains *all*
intermediate types.

But then it could work. No idea if it's in any way reasonable
or useful even if it does work, tho :) :) :)

Actually, it might work kind of nice if Variant.onMatch is used.
Then we'd just have to provide a record where each field corresponds
to a function modifying the respective data depending on one of the
possible data types; the function would itself use Variant.onMatch
since each type of data should be able to interact with every other
type of data.
-}

pipeline :: forall r.
            List (List (Variant r) -> List (Variant r))
         -> Map ChrId (List (Variant r))
         -> Map ChrId (List (Variant r))
pipeline = unsafeCoerce unit

-- Draw data by rendering it only once
drawData' :: forall f a r.
             Foldable f
          => Filterable f
          -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
          => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
          -> Map ChrId { size :: Bp | r}
          -> PureRenderer a
          -> Map ChrId (f a)
          -> Array ChrId
          -> Drawing
drawData' frameBox chrCtx renderer dat chrs = translate 0.0 (frameBox.height - frameBox.yOffset)
                                                $ scale 1.0 (-1.0)
                                                $ drawPureFrames (frames chrs)
  -- TODO add a traceAny statement here to make sure it only runs once
  where drawings :: Map ChrId (f {drawing :: Drawing, point :: _})
        drawings = map (pureRender renderer) dat

        mkFrame :: Bp -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
        mkFrame total chr = do
          {size} <- Map.lookup chr chrCtx
          let width = (unwrap $ size / total) * frameBox.width
          pure { height: frameBox.height, padding: frameBox.padding, width }

        mkFrames :: Array ChrId -> Array { width :: _, height :: _, padding :: _ }
        mkFrames = filterMap (mkFrame $ totalSize chrCtx)

        frames :: Array ChrId -> Array (Tuple (Array _) (_))
        frames chrs' = Array.zip (filterMap (\c -> Array.fromFoldable <$> Map.lookup c drawings) chrs')
                                 (mkFrames chrs')
{-
drawGenes :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> List (Gene r)
          -> Array ChrId
          -> Drawing
drawGenes pos dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where renderer = mkGeneRenderer mouseChrCtx

drawGemma :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> { min :: Number, max :: Number }
          -> List (GWASFeature r)
          -> Array ChrId
          -> Drawing
drawGemma pos s dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer :: PureRenderer (GWASFeature r)
        renderer = mkGwasRenderer s colorsCtx

drawBoth :: forall r.
            { w :: Number, h :: Number
            , p :: Number, y :: Number }
         -> { min :: Number, max :: Number }
         -> Map ChrId (List (Variant ("Gene" :: Gene (), "GWAS" :: GWASFeature ())))
         -> Array ChrId
         -> Drawing
drawBoth pos s dat chrs = drawData pos renderer dat chrs
  where geneR :: PureRenderer (Variant ("Gene" :: Gene ()))
        geneR = tagRenderer (SProxy :: SProxy "Gene") $ mkGeneRenderer mouseChrCtx
        gemmaR :: PureRenderer (Variant ("GWAS" :: GWASFeature ()))
        gemmaR = tagRenderer (SProxy :: SProxy "GWAS") $ mkGwasRenderer s colorsCtx
        colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer = combineRenderers geneR gemmaR
-}

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 $ 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

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs


Removed unnecessary module specifier on call to range in (..)

module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , deleteBy
  , delete
  , (\\)
  , intersectBy
  , intersect
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , span
  ) where

import Control.Alt
import Control.Plus
import Control.Alternative
import Control.MonadPlus
import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

elemIndex :: forall a. (Eq a) => a -> [a] -> Number
elemIndex x = findIndex ((==) x)

elemLastIndex :: forall a. (Eq a) => a -> [a] -> Number
elemLastIndex x = findLastIndex ((==) x)

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = case findIndex (eq x) ys of
  i | i < 0 -> ys
  i -> deleteAt i 1 ys

delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

infix 5 \\

(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter el xs
  where
  el x = findIndex (eq x) ys >= 0

intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

(..) :: Number -> Number -> [Number]
(..) = range

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
    comp' x y = case comp x y of
      GT -> 1
      EQ -> 0
      LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Performs a sorting first.
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs in
                     go ((x:sp.init):acc) op sp.rest

span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []

module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , deleteBy
  , delete
  , (\\)
  , intersectBy
  , intersect
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , span
  ) where

import Control.Alt
import Control.Plus
import Control.Alternative
import Control.MonadPlus
import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

elemIndex :: forall a. (Eq a) => a -> [a] -> Number
elemIndex x = findIndex ((==) x)

elemLastIndex :: forall a. (Eq a) => a -> [a] -> Number
elemLastIndex x = findLastIndex ((==) x)

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = case findIndex (eq x) ys of
  i | i < 0 -> ys
  i -> deleteAt i 1 ys

delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

infix 5 \\

(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter el xs
  where
  el x = findIndex (eq x) ys >= 0

intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
    comp' x y = case comp x y of
      GT -> 1
      EQ -> 0
      LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Performs a sorting first.
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs in
                     go ((x:sp.init):acc) op sp.rest

span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []


Fix import issues

Fix import issues

module Text.Smolder.Renderer.IncrementalDom (render) where

import Prelude
import Control.Monad.Eff (Eff)
import DOM.Event.Event (Event)
import DOM.Event.EventTarget (eventListener)
import Data.Array (singleton)
import Data.CatList (CatList)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, toForeign)
import Data.StrMap (StrMap, delete, lookup, toUnfoldable)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Text.Smolder.Markup (EventHandler(..), Markup)
import Text.Smolder.Renderer.Util (Node(..), renderMarkup)
import Web.IncrementalDOM (IDOM, elementClose, elementOpen, text)

renderAttributes :: StrMap String -> Array (Tuple String Foreign)
renderAttributes = map toForeign >>> toUnfoldable

renderListener :: forall e. EventHandler (Event -> Eff e Unit) -> Tuple String Foreign
renderListener (EventHandler eventName callback) =
  Tuple ("on" <> eventName) (toForeign $ eventListener callback)

renderListeners ::
  forall e.
  CatList (EventHandler (Event -> Eff e Unit)) ->
  Array (Tuple String Foreign)
renderListeners = foldMap (renderListener >>> singleton)

renderNode :: forall e. Node (Event -> Eff e Unit) -> Eff (idom :: IDOM | e) Unit
renderNode (Text t) = text t *> pure unit
renderNode (Element name props listeners children) = do
  let
    key = lookup "key" props
    props' = delete "key" props

  _ <-
    elementOpen name key []
    (renderAttributes props' <> renderListeners listeners)
  _ <- traverse renderNode children
  _ <- elementClose name
  pure unit

render :: forall e. Markup (Event -> Eff e Unit) -> Eff (idom :: IDOM | e) Unit
render markup = do
  _ <- traverse renderNode $ renderMarkup markup
  pure unit

module Text.Smolder.Renderer.IncrementalDom (render) where

import Prelude
import Control.Monad.Eff (Eff)
import DOM.Event.Event (Event)
import DOM.Event.EventTarget (eventListener)
import Data.Array (singleton)
import Data.CatList (CatList)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, toForeign)
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap, toUnfoldable)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Text.Smolder.Markup (EventHandler(..), Markup)
import Text.Smolder.Renderer.Util (Node(..), renderMarkup)
import Web.IncrementalDOM (IDOM, elementClose, elementOpen, text)

renderAttributes :: StrMap String -> Array (Tuple String Foreign)
renderAttributes = map toForeign >>> toUnfoldable

renderListener :: forall e. EventHandler (Event -> Eff e Unit) -> Tuple String Foreign
renderListener (EventHandler eventName callback) =
  Tuple ("on" <> eventName) (toForeign $ eventListener callback)

renderListeners ::
  forall e.
  CatList (EventHandler (Event -> Eff e Unit)) ->
  Array (Tuple String Foreign)
renderListeners = foldMap (renderListener >>> singleton)

renderNode :: forall e. Node (Event -> Eff e Unit) -> Eff (idom :: IDOM | e) Unit
renderNode (Text t) = text t *> pure unit
renderNode (Element name props listeners children) = do
  let
    key = lookup "key" props
    props' = delete "key" props

  _ <-
    elementOpen name key []
    (renderAttributes props' <> renderListeners listeners)
  _ <- traverse renderNode children
  _ <- elementClose name
  pure unit

render :: forall e. Markup (Event -> Eff e Unit) -> Eff (idom :: IDOM | e) Unit
render markup = do
  _ <- traverse renderNode $ renderMarkup markup
  pure unit


rules at beginning and end

rules at beginning and end

module Content.Slide.Test (tests) where

import Prelude (Unit, ($), (==), pure, (<<<), (<>), discard)
import Data.List (List(..), (:))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..))
import Text.Markdown.SlamDown.Syntax (Block(..), Inline(..))
import Test.Unit (suite, test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert)

import Content.Slide (slides)

p1 :: ∀ a. Block a
p1 = Paragraph $ Str "paragraph 1" : Nil

p2 :: ∀ a. Block a
p2 = Paragraph $ Str "paragraph 2" : Nil

p3 :: ∀ a. Block a
p3 = Paragraph $ Str "paragraph 3" : Nil

slam :: ∀ a. Block a -> SlamDownP a
slam = SlamDown <<< pure

blank :: ∀ a. SlamDownP a
blank = SlamDown Nil

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Content.Slide" do
        test "break into slides" do
            let actual = slides $ SlamDown ( p1 : Rule : p2 : p3 : Rule : p1 : Rule : Rule : p2 : Nil) :: SlamDown
            let expected = slam p1 : (slam p2 <> slam p3) : slam p1 : blank : slam p2 : Nil
            assert "break at rules" $ actual == expected
        test "start and end with rules" do
            let actual = slides $ SlamDown ( Rule : p2 : p3 : Rule : Nil) :: SlamDown
            let expected = blank : (slam p2 <> slam p3) : blank : Nil
            assert "break at rules" $ actual == expected

module Content.Slide.Test (tests) where

import Prelude (Unit, ($), (==), pure, (<<<), (<>))
import Data.List (List(..), (:))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..))
import Text.Markdown.SlamDown.Syntax (Block(..), Inline(..))
import Test.Unit (suite, test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert)

import Content.Slide (slides)

p1 :: ∀ a. Block a
p1 = Paragraph $ Str "paragraph 1" : Nil

p2 :: ∀ a. Block a
p2 = Paragraph $ Str "paragraph 2" : Nil

p3 :: ∀ a. Block a
p3 = Paragraph $ Str "paragraph 3" : Nil

slam :: ∀ a. Block a -> SlamDownP a
slam = SlamDown <<< pure

blank :: ∀ a. SlamDownP a
blank = SlamDown Nil

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Content.Slide" do
        test "break into slides" do
            let actual = slides $ SlamDown ( p1 : Rule : p2 : p3 : Rule : p1 : Rule : Rule : p2 : Nil) :: SlamDown
            let expected = slam p1 : (slam p2 <> slam p3) : slam p1 : blank : slam p2 : Nil
            assert "break at rules" $ actual == expected


foldJsonObject -> caseJsonObject

foldJsonObject -> caseJsonObject

module Data.Argonaut.Gen where

import Prelude

import Control.Lazy (class Lazy, defer)
import Control.Monad.Gen (class MonadGen)
import Control.Monad.Gen as Gen
import Control.Monad.Rec.Class (class MonadRec)
import Data.Argonaut.Core as J
import Data.Array as A
import Data.Char as C
import Data.NonEmpty ((:|))
import Data.String as S
import Foreign.Object as Obj

genJson :: forall m. MonadGen m => MonadRec m => Lazy (m J.Json) => m J.Json
genJson = Gen.resize (min 5) $ Gen.sized genJson'
  where
  genJson' :: Int -> m J.Json
  genJson' size
    | size > 1 = Gen.resize (_ - 1) (Gen.choose genJArray genJObject)
    | otherwise = genLeaf

  genLeaf :: m J.Json
  genLeaf = Gen.oneOf $ pure J.jsonNull :| [genJBoolean, genJNumber, genJString]

  genJArray :: m J.Json
  genJArray = J.fromArray <$> Gen.unfoldable (defer \_ -> genJson)

  genJObject :: m J.Json
  genJObject = A.foldM extendJObj J.jsonEmptyObject =<< Gen.unfoldable genString

  extendJObj :: J.Json -> String -> m J.Json
  extendJObj obj k = do
    v <- genJson
    pure $
      J.caseJsonObject
        (J.jsonSingletonObject k v)
        (J.fromObject <<< Obj.insert k v)
        obj

  genJBoolean :: m J.Json
  genJBoolean = J.fromBoolean <$> Gen.chooseBool

  genJNumber :: m J.Json
  genJNumber = J.fromNumber <$> Gen.chooseFloat (-1000000.0) 1000000.0

  genJString :: m J.Json
  genJString = J.fromString <$> genString

  genString :: m String
  genString = S.fromCharArray <$> Gen.unfoldable genChar

  genChar :: m Char
  genChar = C.fromCharCode <$> Gen.chooseInt 0 65535

module Data.Argonaut.Gen where

import Prelude

import Control.Lazy (class Lazy, defer)
import Control.Monad.Gen (class MonadGen)
import Control.Monad.Gen as Gen
import Control.Monad.Rec.Class (class MonadRec)
import Data.Argonaut.Core as J
import Data.Array as A
import Data.Char as C
import Data.NonEmpty ((:|))
import Data.String as S
import Foreign.Object as Obj

genJson :: forall m. MonadGen m => MonadRec m => Lazy (m J.Json) => m J.Json
genJson = Gen.resize (min 5) $ Gen.sized genJson'
  where
  genJson' :: Int -> m J.Json
  genJson' size
    | size > 1 = Gen.resize (_ - 1) (Gen.choose genJArray genJObject)
    | otherwise = genLeaf

  genLeaf :: m J.Json
  genLeaf = Gen.oneOf $ pure J.jsonNull :| [genJBoolean, genJNumber, genJString]

  genJArray :: m J.Json
  genJArray = J.fromArray <$> Gen.unfoldable (defer \_ -> genJson)

  genJObject :: m J.Json
  genJObject = A.foldM extendJObj J.jsonEmptyObject =<< Gen.unfoldable genString

  extendJObj :: J.Json -> String -> m J.Json
  extendJObj obj k = do
    v <- genJson
    pure $
      J.foldJsonObject
        (J.jsonSingletonObject k v)
        (J.fromObject <<< Obj.insert k v)
        obj

  genJBoolean :: m J.Json
  genJBoolean = J.fromBoolean <$> Gen.chooseBool

  genJNumber :: m J.Json
  genJNumber = J.fromNumber <$> Gen.chooseFloat (-1000000.0) 1000000.0

  genJString :: m J.Json
  genJString = J.fromString <$> genString

  genString :: m String
  genString = S.fromCharArray <$> Gen.unfoldable genChar

  genChar :: m Char
  genChar = C.fromCharCode <$> Gen.chooseInt 0 65535


Add 'fork'

Add 'fork'

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , fork
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Monad.Eff (Eff())

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Buffer (Buffer())
import Node.Stream (Readable(), Writable(), Stream())
import Node.ChildProcess.Signal (Signal(..))

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stderr     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdin      :: forall eff. Writable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdout     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , pid        :: Int
  , connected  :: Boolean
  , kill       :: Signal -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stderr = _.stderr <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stdout = _.stdout <<< runChildProcess

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff) Buffer
stdin = _.stdin <<< runChildProcess

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Int
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected = pure <<< _.connected <<< runChildProcess

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = pure (runFn2 cp.send msg handle)

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = pure (cp.kill sig)

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable Signal -> ChildProcessExit
mkChildProcessExit code signal =
  case toMaybe code of
    Just code -> Normally code
    Nothing -> BySignal (unsafeCoerce signal)

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff a. Stream r eff a)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Monad.Eff (Eff())

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Buffer (Buffer())
import Node.Stream (Readable(), Writable(), Stream())
import Node.ChildProcess.Signal (Signal(..))

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stderr     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdin      :: forall eff. Writable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdout     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , pid        :: Int
  , connected  :: Boolean
  , kill       :: Signal -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stderr = _.stderr <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stdout = _.stdout <<< runChildProcess

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff) Buffer
stdin = _.stdin <<< runChildProcess

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Int
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected = pure <<< _.connected <<< runChildProcess

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = pure (runFn2 cp.send msg handle)

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = pure (cp.kill sig)

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable Signal -> ChildProcessExit
mkChildProcessExit code signal =
  case toMaybe code of
    Just code -> Normally code
    Nothing -> BySignal (unsafeCoerce signal)

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff a. Stream r eff a)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)