basic concurrency

basic concurrency

module Client where

import Debug.Trace
import Data.Maybe
import qualified Data.Either as E
import Data.JSON
import Data.Tuple
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types (DOM(), DOMEvent(), DOMLocation())
import Data.DOM.Simple.Window (globalWindow, location)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

import qualified BrowserWebSocket as WS
import Rendering
import Game
import Types
import Utils

foreign import host
  """
  function host(location) {
    return location.host;
  }
  """ :: DOMLocation -> String

initialState :: ClientState
initialState =
  { game: initialGame
  , prevGame: initialGame
  , redrawMap: true
  }

data Owner = RenderLoop | WebSocketLoop

instance eqOwner :: Eq Owner where
  (==) RenderLoop RenderLoop = true
  (==) WebSocketLoop WebSocketLoop = true
  (==) _ _ = false
  (/=) x y = not (x == y)

instance showOwner :: Show Owner where
  show RenderLoop = "RenderLoop"
  show WebSocketLoop = "WebSocketLoop"

waitForOwnership :: forall e.
  Owner
  -> RefVal (Maybe Owner)
  -> Eff (ref :: Ref, trace :: Trace, timer :: Timer | e) Unit
  -> Eff (ref :: Ref, trace :: Trace, timer :: Timer | e) Unit
waitForOwnership owner ownerRef action = go
  where
  go = do
    currentOwner <- readRef ownerRef
    case currentOwner of
      Just o ->
        if o == owner
           then trace $ "wtf: ownerRef is already set to " <> show owner
           else do
             trace $ "waiting for " <> show o <> " to relinquish ownership"
             void $ timeout 1 go
      Nothing -> do
        writeRef ownerRef (Just owner)
        action
        writeRef ownerRef (Nothing)

main = do
  ctx <- setupRendering
  state <- newRef initialState

  -- who currently 'owns' the state ref.
  owner <- newRef (Nothing :: Maybe Owner)

  h <- host <$> location globalWindow
  socket <- WS.mkWebSocket $ "ws://" <> h <> "/"
  WS.onMessage socket $ \msg -> do
    case eitherDecode msg of
      E.Left err ->
        trace $ "failed to parse message from server: " <> err
      E.Right update ->
        waitForOwnership WebSocketLoop owner $
          modifyRef state $ \s -> s { game = applyGameUpdate update s.game
                                    , prevGame = s.game
                                    }

  addKeyboardEventListener
    KeydownEvent
    (handleKeydown socket)
    globalWindow

  startAnimationLoop $
    waitForOwnership RenderLoop owner $ do
      s <- readRef state
      render ctx s
      when (s.redrawMap) $
        writeRef state (s { redrawMap = false })

handleKeydown :: forall e.
  WS.Socket -> DOMEvent -> Eff (ws :: WS.WebSocket, dom :: DOM | e) Unit
handleKeydown socket event = do
  code <- keyCode event
  whenJust (directionFromKeyCode code) $ \direction ->
    WS.send socket (encode direction)

directionFromKeyCode :: Number -> Maybe Direction
directionFromKeyCode code =
  case code of
    38 -> Just Up
    40 -> Just Down
    37 -> Just Left
    39 -> Just Right
    _  -> Nothing

foreign import startAnimationLoop
  """
  function startAnimationLoop(action) {
    return function go() {
      window.requestAnimationFrame(go);
      action();
    }
  }
  """ :: forall a e. Eff e a -> Eff e Unit

module Client where

import Debug.Trace
import Data.Maybe
import qualified Data.Either as E
import Data.JSON
import Data.Tuple
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types (DOM(), DOMEvent(), DOMLocation())
import Data.DOM.Simple.Window (globalWindow, location)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

import qualified BrowserWebSocket as WS
import Rendering
import Game
import Types
import Utils

foreign import host
  """
  function host(location) {
    return location.host;
  }
  """ :: DOMLocation -> String

initialState :: ClientState
initialState =
  { game: initialGame
  , prevGame: initialGame
  , redrawMap: true
  }

main = do
  ctx <- setupRendering
  state <- newRef initialState

  h <- host <$> location globalWindow
  socket <- WS.mkWebSocket $ "ws://" <> h <> "/"
  WS.onMessage socket $ \msg -> do
    case eitherDecode msg of
      E.Left err ->
        trace $ "failed to parse message from server: " <> err
      E.Right update ->
        modifyRef state $ \s -> s { game = applyGameUpdate update s.game
                                  , prevGame = s.game
                                  }

  addKeyboardEventListener
    KeydownEvent
    (handleKeydown socket)
    globalWindow

  startAnimationLoop $ do
    s <- readRef state
    render ctx s
    when (s.redrawMap) $
      writeRef state (s { redrawMap = false })

handleKeydown :: forall e.
  WS.Socket -> DOMEvent -> Eff (ws :: WS.WebSocket, dom :: DOM | e) Unit
handleKeydown socket event = do
  code <- keyCode event
  whenJust (directionFromKeyCode code) $ \direction ->
    WS.send socket (encode direction)

directionFromKeyCode :: Number -> Maybe Direction
directionFromKeyCode code =
  case code of
    38 -> Just Up
    40 -> Just Down
    37 -> Just Left
    39 -> Just Right
    _  -> Nothing

foreign import startAnimationLoop
  """
  function startAnimationLoop(action) {
    return function go() {
      window.requestAnimationFrame(go);
      action();
    }
  }
  """ :: forall a e. Eff e a -> Eff e Unit


Attempt at bounding box rewrite

Attempt at bounding box rewrite

module Genetics.Browser.GlyphPosition where
       -- ( GlyphPosition(..)
       -- )
       -- where

import Prelude

import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Ord.Max (Max(..))
import Data.Ord.Min (Min(..))
import Global (infinity)
import Math as Math

-- this is really a silly way of checking whether the user has clicked on a glyph or not.
-- instead of simply using rectangular bounding boxes (encoded with constant functions??)
-- we should have a general collide(x,y) function. that function should return true if
-- (x,y) is within the glyph, and false otherwise. How it is calculated is up to the glyph.

-- for example a haplotype plot would use a simple rectangle check, but a QTL plot could
-- check to see if the click was within some radius of the data point (right now lineplots
-- can't really have positions!)

-- | GlyphPositions are used by Biodalliance to calculate the hitbox for a glyph,
-- | for seeing if the user has clicked on it.
-- | Easily combined using the Monoid instance.
newtype GlyphPosition = GlyphPos { min :: Number
                                 , max :: Number
                                 , minY :: Number
                                 , maxY :: Number
                                 }

derive instance genericGlyphPosition :: Generic GlyphPosition _
derive instance newtypeGlyphPosition :: Newtype GlyphPosition _
derive instance eqGlyphPosition :: Eq GlyphPosition

                   -- GlyphPos { min, max, minY, maxY }

instance showGlyphPosition :: Show GlyphPosition where
  show (GlyphPos (gp)) = "{ min: "  <> show gp.min  <>
                         ", max: "  <> show gp.max  <>
                         ", minY: " <> show gp.minY <>
                         ", maxY: " <> show gp.maxY <>
                         " }"

instance semigroupGlyphPosition :: Semigroup GlyphPosition where
  append (GlyphPos (p1)) (GlyphPos (p2)) =
    GlyphPos ({ min: Math.min  p1.min  p2.min
              , max: Math.max  p1.max  p2.max
              , minY: Math.min p1.minY p2.minY
              , maxY: Math.max p1.maxY p2.maxY
              })

instance monoidGlyphPosition :: Monoid GlyphPosition where
  mempty = GlyphPos { min:  infinity
                    , max:  (-infinity)
                    , minY: infinity
                    , maxY: (-infinity)
                    }

newtype BBox a = BBox { min :: Maybe (Min a)
                      , max :: Maybe (Max a)
                      , minY :: Maybe (Min a)
                      , maxY :: Maybe (Max a)
                      }

instance functorBBox :: Functor BBox where
  map f (BBox b) = BBox $ { min:  map (over Min f) b.min
                          , max:  map (over Max f) b.max
                          , minY: map (over Min f) b.minY
                          , maxY: map (over Max f) b.maxY
                          }

instance semigroupBBox :: Ord a => Semigroup (BBox a) where
  append (BBox b1) (BBox b2) =
    BBox { min:  b1.min  <> b2.min
         , max:  b1.max  <> b2.max
         , minY: b1.minY <> b2.minY
         , maxY: b1.maxY <> b2.maxY
         }

instance monoidBBox :: Ord a => Monoid (BBox a) where
  mempty = BBox { min: Nothing
                , max: Nothing
                , minY: Nothing
                , maxY: Nothing
                }

mkBB :: Number -> Number -> Number -> Number -> BBox Number
mkBB min max minY maxY = BBox { min: pure $ wrap min
                              , max: pure $ wrap max
                              , minY: pure $ wrap min
                              , maxY: pure $ wrap max
                              }

module Genetics.Browser.GlyphPosition
       ( GlyphPosition(..)
       )
       where

import Prelude

import Data.Generic.Rep (class Generic)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype)
import Global (infinity)
import Math as Math

-- this is really a silly way of checking whether the user has clicked on a glyph or not.
-- instead of simply using rectangular bounding boxes (encoded with constant functions??)
-- we should have a general collide(x,y) function. that function should return true if
-- (x,y) is within the glyph, and false otherwise. How it is calculated is up to the glyph.

-- for example a haplotype plot would use a simple rectangle check, but a QTL plot could
-- check to see if the click was within some radius of the data point (right now lineplots
-- can't really have positions!)

-- | GlyphPositions are used by Biodalliance to calculate the hitbox for a glyph,
-- | for seeing if the user has clicked on it.
-- | Easily combined using the Monoid instance.
newtype GlyphPosition = GlyphPos { min :: Number
                                 , max :: Number
                                 , minY :: Number
                                 , maxY :: Number
                                 }

derive instance genericGlyphPosition :: Generic GlyphPosition _
derive instance newtypeGlyphPosition :: Newtype GlyphPosition _
derive instance eqGlyphPosition :: Eq GlyphPosition

                   -- GlyphPos { min, max, minY, maxY }

instance showGlyphPosition :: Show GlyphPosition where
  show (GlyphPos (gp)) = "{ min: "  <> show gp.min  <>
                         ", max: "  <> show gp.max  <>
                         ", minY: " <> show gp.minY <>
                         ", maxY: " <> show gp.maxY <>
                         " }"

instance semigroupGlyphPosition :: Semigroup GlyphPosition where
  append (GlyphPos (p1)) (GlyphPos (p2)) =
    GlyphPos ({ min: Math.min  p1.min  p2.min
              , max: Math.max  p1.max  p2.max
              , minY: Math.min p1.minY p2.minY
              , maxY: Math.max p1.maxY p2.maxY
              })

instance monoidGlyphPosition :: Monoid GlyphPosition where
  mempty = GlyphPos { min:  infinity
                    , max:  (-infinity)
                    , minY: infinity
                    , maxY: (-infinity)
                    }


Write drawing function that only renders Data -> Drawing once (yay purity!)

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

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

drawData :: forall f a.
            Foldable f
         => { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData {w,h,p,y} renderer dat chrs =
  let features :: Map ChrId (Array a)
      features = map Array.fromFoldable
                 $ Map.filterKeys (\k -> k `Array.elem` chrs) dat

      readyFrames :: Map ChrId { size :: Bp, frame :: ReadyFrame (Array a) }
      readyFrames = addHeight h $ mouseChrFrames w p features

      toDraw :: Array (ReadyFrame (Array a))
      toDraw = _.frame  <$> (filterMap (\chr -> Map.lookup chr readyFrames) chrs)

  in translate 0.0 (h-y) $ scale 1.0 (-1.0) $ drawFrames toDraw renderer

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

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

drawData :: forall f a.
            Foldable f
         => { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData {w,h,p,y} renderer dat chrs =
  let features :: Map ChrId (Array a)
      features = map Array.fromFoldable
                 $ Map.filterKeys (\k -> k `Array.elem` chrs) dat

      readyFrames :: Map ChrId { size :: Bp, frame :: ReadyFrame (Array a) }
      readyFrames = addHeight h $ mouseChrFrames w p features

      toDraw :: Array (ReadyFrame (Array a))
      toDraw = _.frame  <$> (filterMap (\chr -> Map.lookup chr readyFrames) chrs)

  in translate 0.0 (h-y) $ scale 1.0 (-1.0) $ drawFrames toDraw renderer

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


Moved aeson encoding to argonaut fork

Moved aeson encoding to argonaut fork

module Gonimo.Server where

import Prelude

import Control.Monad.Aff (runAff)
import Control.Monad.Aff.Console (log)
import qualified Control.Monad.Aff as Aff
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)
import Data.Generic
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Request
import Data.Argonaut.Encode

type FamilyId = Int
type EmailAddress = String

data Invitation = EmailInvitation EmailAddress

derive instance genericInvitation :: Generic Invitation

-- instance isForeignInvitation :: IsForeign Invitation where
--  read = readGeneric defaultOptions

sendInvitation :: forall e . FamilyId -> Invitation -> Affjax e String
sendInvitation fid inv = post "http://localhost:8081/families/10/invitations" (gAesonEncodeJson inv)

module Gonimo.Server where

import Prelude

import Control.Monad.Aff (runAff)
import Control.Monad.Aff.Console (log)
import qualified Control.Monad.Aff as Aff
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)
import Data.Generic
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Request
import Data.Argonaut.Encode

-- For gEncodeJson:
import Data.Argonaut.Core (Json(), jsonNull, fromBoolean, fromNumber, fromString, fromArray, fromObject)
import Data.Either (Either(), either)
import Data.Foldable (foldr)
import Data.Generic (Generic, GenericSpine(..), toSpine, GenericSignature(..), DataConstructor())
import Data.Int (toNumber)
import Data.List (List(..), fromList)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String (fromChar, lastIndexOf, drop)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))
import Data.Array (null, concatMap, filter)
import Type.Proxy (Proxy(..))
-- import Partial.Unsafe (unsafeCrashWith)

type FamilyId = Int
type EmailAddress = String

data Invitation = EmailInvitation EmailAddress

derive instance genericInvitation :: Generic Invitation

-- instance isForeignInvitation :: IsForeign Invitation where
--  read = readGeneric defaultOptions

sendInvitation :: forall e . FamilyId -> Invitation -> Affjax e String
sendInvitation fid inv = post "http://localhost:8081/families/10/invitations" (gAesonEncodeJson inv)

gAesonEncodeJson :: forall a. (Generic a) => a -> Json
gAesonEncodeJson = gAesonEncodeJson' sign <<< toSpine
  where sign = toSignature (Proxy :: Proxy a)

-- | Encode `GenericSpine` into `Json`.
gAesonEncodeJson' :: GenericSignature -> GenericSpine -> Json
gAesonEncodeJson' sign spine = case spine of
 SInt x            -> fromNumber $ toNumber x
 SString x         -> fromString x
 SChar x           -> fromString $ fromChar x
 SNumber x         -> fromNumber x
 SBoolean x        -> fromBoolean x
 SArray thunks     -> fromArray (gAesonEncodeJson' sign <<< (unit #) <$> thunks)
 SProd constr args -> case sign of
                        SigProd _ constrSigns -> gAesonEncodeProdJson' constrSigns constr args
                      --  _ -> unsafeCrashWith "Signature does not match value, please don't do that!" -- Not yet supported, waiting for purescript 0.8
 SRecord fields    -> fromObject $ foldr addField SM.empty fields
   where addField field = SM.insert field.recLabel
                                    (gEncodeJson' $ field.recValue unit)

gAesonEncodeProdJson' :: Array DataConstructor -> String -> Array (Unit -> GenericSpine) -> Json
gAesonEncodeProdJson' constrSigns constr args = fromObject
                                          $ SM.insert "tag" (encodeJson fixedConstr)
                                          $ SM.singleton "contents" flattenedArgs
  where
    fixedConstr      = case lastIndexOf "." constr of
                        Nothing -> constr
                        Just i -> drop (i+1) constr
    allConstrNullary = foldr (&&) true <<< map (\c -> null c.sigValues) $ constrSigns
    contents         = if allConstrNullary -- If no constructor has any values - serialize as string ...
                       then fromString constr
                       else flattenedArgs
    encodedArgs      = gAesonEncodeProdArgs constrSigns constr args
    flattenedArgs    = case encodedArgs of
                        [a] -> a
                        as  -> encodeJson as

gAesonEncodeProdArgs :: Array DataConstructor -> String -> Array (Unit -> GenericSpine) -> Array (Json)
gAesonEncodeProdArgs constrSigns constr args = gAesonEncodeJson' <$> sigValues <*> values
  where
   lSigValues = concatMap (\c -> c.sigValues)
                   <<< filter (\c -> c.sigConstructor == constr) $ constrSigns
   sigValues = (unit #) <$> lSigValues
   values = (unit #) <$> args


Simpler way to build websocket url

Simpler way to build websocket url

module Main where

import Prelude
import Data.Either
import Data.Maybe
import App.Layout (Action(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (host,port)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match,Route)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- getRouteSignal
  -- | Create a signal for WebSocket stats data
  socketSignal <- getSocketSignal
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs:
        [ routeSignal ~> match ~> PageView
        , socketSignal ~> Received ] }

getSocketSignal :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Socket.Action)
getSocketSignal = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  pure $ subscribe wsInput

getRouteSignal :: forall eff. Eff (dom :: DOM | eff) (Signal String)
getRouteSignal = do
  urlSignal <- sampleUrl
  pure $ urlSignal

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl =
  let loc = (window >>= location) in do
  host <- loc >>= host
  pure $ "ws://" <> host <> "/ws/stats"

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ ->
      let msg = "Could not convert " <> url <> "to the stats websocket URL" in
      throwException $ error msg

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app

module Main where

import Prelude
import Data.Either
import Data.Maybe
import App.Layout (Action(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match,Route)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- getRouteSignal
  -- | Create a signal for WebSocket stats data
  socketSignal <- getSocketSignal
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs:
        [ routeSignal ~> match ~> PageView
        , socketSignal ~> Received ] }

getSocketSignal :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Socket.Action)
getSocketSignal = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  pure $ subscribe wsInput

getRouteSignal :: forall eff. Eff (dom :: DOM | eff) (Signal String)
getRouteSignal = do
  urlSignal <- sampleUrl
  pure $ urlSignal

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl = window >>= location >>= pathname >>= convertToWsUrl

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ ->
      let msg = "Could not convert " <> url <> "to the stats websocket URL" in
      throwException $ error msg

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app


legend for two y axes

legend for two y axes

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.BuildChart.Line.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Line.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Line.Model (Model, LineR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  let res = Port.ChartInstructions (buildLine conf records axes) Line
  pure res

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  , rightItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  }

buildLineData ∷ LineR → JArray → Array LineSerie
buildLineData r records = series
  where
  -- | maybe series >> dimension >> left values × right values × symbol sizes
  dataMap ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.dimension of
      Nothing → acc
      Just dimKey →
        let
          mbSeries =
            getMaybeStringFromJson =<< r.series
          leftValues =
            getValuesFromJson $ pure r.value
          rightValues =
            getValuesFromJson r.secondValue
          sizes =
            getValuesFromJson r.size

          alterSeriesFn
            ∷ Maybe (String >> (Array Number × Array Number × Array Number))
            → Maybe (String >> (Array Number × Array Number × Array Number))
          alterSeriesFn Nothing =
            Just $ M.singleton dimKey $ leftValues × rightValues × sizes
          alterSeriesFn (Just dims) =
            Just $ M.alter alterDimFn dimKey dims

          alterDimFn
            ∷ Maybe (Array Number × Array Number × Array Number)
            → Maybe (Array Number × Array Number × Array Number)
          alterDimFn Nothing =
            Just $ leftValues × rightValues × sizes
          alterDimFn (Just (ls × rs × ss)) =
            Just $ (ls ⊕ leftValues) × (rs ⊕ rightValues) × (ss ⊕ sizes)
        in
          M.alter alterSeriesFn mbSeries acc

  series ∷ Array LineSerie
  series =
    foldMap mkLineSerie $ M.toList dataMap

  mkLineSerie
    ∷ Maybe String × (String >> (Array Number × Array Number × Array Number))
    → Array LineSerie
  mkLineSerie (name × items) =
    [{ name
     , leftItems: adjustSymbolSizes $ map mkLeftItem items
     , rightItems: adjustSymbolSizes $ map mkRightItem items
     } ]

  mkLeftItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkLeftItem (ls × _ × ss) =
    let
      value = Ag.runAggregation r.valueAggregation ls
      symbolSize = maybe zero (\ag → Int.floor $ Ag.runAggregation ag ss) r.sizeAggregation
    in {value, symbolSize}

  mkRightItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkRightItem (_ × rs × ss) =
    case r.secondValueAggregation  of
      Nothing → {symbolSize: zero, value: zero}
      Just valAgg →
        let
          value = Ag.runAggregation valAgg rs
          symbolSize = maybe zero (\ag → Int.floor $ Ag.runAggregation ag ss) r.sizeAggregation
        in {value, symbolSize}

  adjustSymbolSizes
    ∷ ∀ f
    . (Functor f, Foldable f)
    ⇒ f {value ∷ Number, symbolSize ∷ Int}
    → f {value ∷ Number, symbolSize ∷ Int}
  adjustSymbolSizes items =
    let
      minValue ∷ Number
      minValue =
        Int.toNumber
          $ fromMaybe bottom
          $ map _.symbolSize
          $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) items

      maxValue ∷ Number
      maxValue =
        Int.toNumber
          $ fromMaybe top
          $ map _.symbolSize
          $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) items

      distance ∷ Number
      distance =
        maxValue - minValue

      sizeDistance ∷ Number
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Int → Int
      relativeSize val
        | distance ≡ 0.0 = val
        | otherwise =
          Int.floor
          $ r.maxSize
          - sizeDistance / distance * (maxValue - Int.toNumber val)
    in
      map (\x → x{symbolSize = relativeSize x.symbolSize}) items

buildLine ∷ LineR → JArray → Axes → DSL OptionI
buildLine r records axes = do
  E.tooltip case r.size of
    Just _ → E.triggerItem
    Nothing → E.triggerAxis
  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    traverse_ E.interval xAxisConfig.interval
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  lineData ∷ Array LineSerie
  lineData = buildLineData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.dimension axes

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.dimension axes

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames = case r.series of
    Just _ → A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData
    Nothing → map show $ A.catMaybes [ Just r.value, r.secondValue ]

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          E.name $ show r.value

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          traverse_ (E.name ∘ show) r.secondValue

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.BuildChart.Line.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Line.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Line.Model (Model, LineR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  let res = Port.ChartInstructions (buildLine conf records axes) Line
  pure res

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  , rightItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  }

buildLineData ∷ LineR → JArray → Array LineSerie
buildLineData r records = series
  where
  -- | maybe series >> dimension >> left values × right values × symbol sizes
  dataMap ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.dimension of
      Nothing → acc
      Just dimKey →
        let
          mbSeries =
            getMaybeStringFromJson =<< r.series
          leftValues =
            getValuesFromJson $ pure r.value
          rightValues =
            getValuesFromJson r.secondValue
          sizes =
            getValuesFromJson r.size

          alterSeriesFn
            ∷ Maybe (String >> (Array Number × Array Number × Array Number))
            → Maybe (String >> (Array Number × Array Number × Array Number))
          alterSeriesFn Nothing =
            Just $ M.singleton dimKey $ leftValues × rightValues × sizes
          alterSeriesFn (Just dims) =
            Just $ M.alter alterDimFn dimKey dims

          alterDimFn
            ∷ Maybe (Array Number × Array Number × Array Number)
            → Maybe (Array Number × Array Number × Array Number)
          alterDimFn Nothing =
            Just $ leftValues × rightValues × sizes
          alterDimFn (Just (ls × rs × ss)) =
            Just $ (ls ⊕ leftValues) × (rs ⊕ rightValues) × (ss ⊕ sizes)
        in
          M.alter alterSeriesFn mbSeries acc

  series ∷ Array LineSerie
  series =
    foldMap mkLineSerie $ M.toList dataMap

  mkLineSerie
    ∷ Maybe String × (String >> (Array Number × Array Number × Array Number))
    → Array LineSerie
  mkLineSerie (name × items) =
    [{ name
     , leftItems: adjustSymbolSizes $ map mkLeftItem items
     , rightItems: adjustSymbolSizes $ map mkRightItem items
     } ]

  mkLeftItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkLeftItem (ls × _ × ss) =
    let
      value = Ag.runAggregation r.valueAggregation ls
      symbolSize = maybe zero (\ag → Int.floor $ Ag.runAggregation ag ss) r.sizeAggregation
    in {value, symbolSize}

  mkRightItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkRightItem (_ × rs × ss) =
    case r.secondValueAggregation  of
      Nothing → {symbolSize: zero, value: zero}
      Just valAgg →
        let
          value = Ag.runAggregation valAgg rs
          symbolSize = maybe zero (\ag → Int.floor $ Ag.runAggregation ag ss) r.sizeAggregation
        in {value, symbolSize}

  adjustSymbolSizes
    ∷ ∀ f
    . (Functor f, Foldable f)
    ⇒ f {value ∷ Number, symbolSize ∷ Int}
    → f {value ∷ Number, symbolSize ∷ Int}
  adjustSymbolSizes items =
    let
      minValue ∷ Number
      minValue =
        Int.toNumber
          $ fromMaybe bottom
          $ map _.symbolSize
          $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) items

      maxValue ∷ Number
      maxValue =
        Int.toNumber
          $ fromMaybe top
          $ map _.symbolSize
          $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) items

      distance ∷ Number
      distance =
        maxValue - minValue

      sizeDistance ∷ Number
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Int → Int
      relativeSize val
        | distance ≡ 0.0 = val
        | otherwise =
          Int.floor
          $ r.maxSize
          - sizeDistance / distance * (maxValue - Int.toNumber val)
    in
      map (\x → x{symbolSize = relativeSize x.symbolSize}) items

buildLine ∷ LineR → JArray → Axes → DSL OptionI
buildLine r records axes = do
  E.tooltip E.triggerItem
  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    traverse_ E.interval xAxisConfig.interval
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  lineData ∷ Array LineSerie
  lineData = buildLineData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.dimension axes

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.dimension axes

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      for_ lineSerie.name E.name

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.value value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      for_ lineSerie.name E.name

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"


Allows for function to be spread out in multiple places

module CodeSnippet where

import Data.Array as A
import Control.Monad.Aff (Aff, attempt)
import Data.Either (either, Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.List (List(..))
import Data.Map (Map, fromFoldableWith)
-- import Data.Maybe (Maybe(..))
import Data.Show (class Show)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (get, AJAX)
import Prelude (bind, pure, (<>), (<<<), show, ($), (*>), (<*), const, id, (<$>), unit)
import Text.Parsing.StringParser (Parser, runParser)
import Text.Parsing.StringParser.Combinators (sepEndBy, manyTill, many, choice, lookAhead)
import Text.Parsing.StringParser.String (string, anyChar, noneOf, eof)

data Language = Purescript
              | Elm
              | Haskell
              | Idris
              | Clojure
              | Scheme
              | Elixir
              | Scala

derive instance eqLanguage :: Eq Language

comment :: Language -> String
comment Purescript = "--"
comment Elm = "--"
comment Haskell = "--"
comment Idris = "--"
comment Clojure = ";"
comment Scheme = ";"
comment Elixir = "#"
comment Scala = "//"

suffix :: Language -> String
suffix Purescript = "purs"
suffix Elm = "elm"
suffix Haskell = "hs"
suffix Idris = "idr"
suffix Clojure = "clj"
suffix Scheme = "scm"
suffix Elixir = "ex"
suffix Scala = "scala"

data SourceCode = SourceCode { getSourceCode :: String
                             , language :: Language
                             }
data FunctionBlock = FunctionBlock { name :: String
                                   , body :: String
                                   }

instance showSourceCode :: Show SourceCode where
  show (SourceCode sc) = sc.getSourceCode

instance showFunctionBlock :: Show FunctionBlock where
  show (FunctionBlock f) = f.name <> ": " <> f.body

getFile :: forall eff. String -> Language -> Aff (ajax :: AJAX | eff) (Either String SourceCode)
getFile fname lang = do
  let fullname = "/src/Structures/" <> fname <> "." <> suffix lang
  res <- attempt $ get fullname
  pure $ either (Left <<< show) (\r -> Right $ SourceCode { getSourceCode : r.response
                                                          , language : lang
                                                          }) res

docComment :: Language -> Parser String
docComment lang = string (comment lang <> " | *")

fromCharList :: List Char -> String
fromCharList = fromCharArray <<< A.fromFoldable

functionTag :: Language -> Parser String
functionTag lang = fromCharList <$> (docComment lang *> many (noneOf ['\n']))

endComment :: Language -> Parser String
endComment lang = string (comment lang <> " .end")

functionBody :: Language -> Parser FunctionBlock
functionBody lang = do
  name <- functionTag lang
  body <- manyTill anyChar $ endComment lang
  pure $ FunctionBlock { name : name
                       , body : fromCharList body
                       }

functions :: Language -> Parser (List FunctionBlock)
functions lang = sepEndBy (functionBody lang) (nextFunction lang)

nextFunction :: Language -> Parser (List Char)
nextFunction lang = manyTill anyChar (choice [eof, (const unit <$> lookAhead (functionTag lang))])

parseFunctions :: SourceCode -> Map String String
parseFunctions (SourceCode code) =
  let
    res = runParser (nextFunction code.language *> functions code.language) code.getSourceCode
    fns = either (const Nil) id res
  in
   fromFoldableWith (<>) (map (\ (FunctionBlock f) -> Tuple f.name f.body) fns)

testString :: String
testString = """
-- | *DataStructure Stack
data Stack a = Nil
             | Cons a (Stack a)
-- .end

-- | *empty
empty :: forall a. Stack a
empty = Nil
-- .end

-- | *head
head :: forall a. Stack a -> Maybe a
head Nil = Nothing
head (Cons x _) = Just x
-- .end

-- | *tail
tail :: forall a. Stack a -> Maybe (Stack a)
tail Nil = Nothing
tail (Cons _ xs) = Just xs
-- .end
"""

testSC :: SourceCode
testSC = SourceCode { getSourceCode: testString
                    , language: Purescript
                    }

module CodeSnippet where

import Data.Array as A
import Control.Monad.Aff (Aff, attempt)
import Data.Either (either, Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.List (List(..))
import Data.Map (Map, fromFoldable)
-- import Data.Maybe (Maybe(..))
import Data.Show (class Show)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (get, AJAX)
import Prelude (bind, pure, (<>), (<<<), show, ($), (*>), (<*), const, id, (<$>), unit)
import Text.Parsing.StringParser (Parser, runParser)
import Text.Parsing.StringParser.Combinators (sepEndBy, manyTill, many, choice, lookAhead)
import Text.Parsing.StringParser.String (string, anyChar, noneOf, eof)

data Language = Purescript
              | Elm
              | Haskell
              | Idris
              | Clojure
              | Scheme
              | Elixir
              | Scala

derive instance eqLanguage :: Eq Language

comment :: Language -> String
comment Purescript = "--"
comment Elm = "--"
comment Haskell = "--"
comment Idris = "--"
comment Clojure = ";"
comment Scheme = ";"
comment Elixir = "#"
comment Scala = "//"

suffix :: Language -> String
suffix Purescript = "purs"
suffix Elm = "elm"
suffix Haskell = "hs"
suffix Idris = "idr"
suffix Clojure = "clj"
suffix Scheme = "scm"
suffix Elixir = "ex"
suffix Scala = "scala"

data SourceCode = SourceCode { getSourceCode :: String
                             , language :: Language
                             }
data FunctionBlock = FunctionBlock { name :: String
                                   , body :: String
                                   }

instance showSourceCode :: Show SourceCode where
  show (SourceCode sc) = sc.getSourceCode

instance showFunctionBlock :: Show FunctionBlock where
  show (FunctionBlock f) = f.name <> ": " <> f.body

getFile :: forall eff. String -> Language -> Aff (ajax :: AJAX | eff) (Either String SourceCode)
getFile fname lang = do
  let fullname = "/src/Structures/" <> fname <> "." <> suffix lang
  res <- attempt $ get fullname
  pure $ either (Left <<< show) (\r -> Right $ SourceCode { getSourceCode : r.response
                                                          , language : lang
                                                          }) res

docComment :: Language -> Parser String
docComment lang = string (comment lang <> " | *")

fromCharList :: List Char -> String
fromCharList = fromCharArray <<< A.fromFoldable

functionTag :: Language -> Parser String
functionTag lang = fromCharList <$> (docComment lang *> many (noneOf ['\n']))

endComment :: Language -> Parser String
endComment lang = string (comment lang <> " .end")

functionBody :: Language -> Parser FunctionBlock
functionBody lang = do
  name <- functionTag lang
  body <- manyTill anyChar $ endComment lang
  pure $ FunctionBlock { name : name
                       , body : fromCharList body
                       }

functions :: Language -> Parser (List FunctionBlock)
functions lang = sepEndBy (functionBody lang) (nextFunction lang)

nextFunction :: Language -> Parser (List Char)
nextFunction lang = manyTill anyChar (choice [eof, (const unit <$> lookAhead (functionTag lang))])

parseFunctions :: SourceCode -> Map String String
parseFunctions (SourceCode code) =
  let
    res = runParser (nextFunction code.language *> functions code.language) code.getSourceCode
    fns = either (const Nil) id res
  in
   fromFoldable (map (\ (FunctionBlock f) -> Tuple f.name f.body) fns)

testString :: String
testString = """
-- | *DataStructure Stack
data Stack a = Nil
             | Cons a (Stack a)
-- .end

-- | *empty
empty :: forall a. Stack a
empty = Nil
-- .end

-- | *head
head :: forall a. Stack a -> Maybe a
head Nil = Nothing
head (Cons x _) = Just x
-- .end

-- | *tail
tail :: forall a. Stack a -> Maybe (Stack a)
tail Nil = Nothing
tail (Cons _ xs) = Just xs
-- .end
"""

testSC :: SourceCode
testSC = SourceCode { getSourceCode: testString
                    , language: Purescript
                    }