Allow ctrl+r to reload the page

Allow ctrl+r to reload the page

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> [TransformerId]
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> []

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
        let active = foldl (\sm id -> SM.insert id (getTransformerRecord chapter id) sm) SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "levels" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = map (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "Program: " ++ show tids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Cyan `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> do
                   ctrlPressed <- ctrlKey event
                   when (not ctrlPressed) $
                       modifyGameStateAndRender true $ \gs ->
                           gs { levelState = SM.insert gs.currentLevel [] gs.levelState }
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement doc "option"
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> [TransformerId]
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> []

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
        let active = foldl (\sm id -> SM.insert id (getTransformerRecord chapter id) sm) SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "levels" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = map (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "Program: " ++ show tids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Cyan `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> modifyGameStateAndRender true $ \gs ->
                   gs { levelState = SM.insert gs.currentLevel [] gs.levelState }
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement doc "option"
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs


Decouple view update commands from rendering

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, Producer, connect, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds(..), delay, finally, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVarStatus(..), makeEmptyVar, makeVar, putVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as Aff
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter)
import Data.Foldable (class Foldable, foldMap, for_, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

-- set an event to fire on the given button id

foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1) (ZoomView s2) = ZoomView (s1 + s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "17103129"
      , Tuple "Y"   "9174469"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

updateViewTimed :: ViewRange
                -> Milliseconds
                -> AVar ViewRange
                -> UpdateView
                -> Aff _ Unit
updateViewTimed (Pair limL limR) timeout av cmd = do
  delay timeout
  vr <- takeVar av
      -- update view using received cmd, limiting view to provided boundaries
  let (Pair l' r') = updateViewFold cmd vr
      -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
      vr' = Pair (max limL l')
                 (min (max r' (l' + BigInt.fromInt 400))
                      limR)
  putVar vr' av

viewMachine :: forall r.
               CoordSys _ _
            -> { viewRangeState :: AVar ViewRange
               , viewCmds :: AVar UpdateView | r }
            -> AVar Unit
            -> Aff _ Unit
viewMachine cs { viewRangeState, viewCmds } ready = do

  curCmdVar <- makeVar mempty

  let viewLimit = Pair zero (cs^._TotalSize)

      loop' updater = do
        cmd <- takeVar viewCmds

        killFiber (error "Resetting view update") updater

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        liftEff $ do
          log $ show curCmd <> " <> " <> show cmd <> " = " <> show cmd'

        updater' <- forkAff do
                      updateViewTimed viewLimit (wrap 500.0) viewRangeState cmd'

                      putVar unit ready

                      takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewState   :: AVar BrowserState
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ Unit)}
           -> Aff _ Unit
renderLoop cSys browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      (Pair l _ ) = vState.visible
      offset = BigInt.toNumber l / scale
      tracks = browser.tracks vState.visible

  -- fork a new renderFiber
  renderFiber <- forkAff $ renderGlyphs vState.visible scale tracks canvases
  putVar renderFiber state.renderFiber

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~
    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      Drawing.render trackCtx $ browser.relativeUI vState.visible

    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

      -- update view using received cmd, limiting view to coordsys
  let (Pair l' r') = updateViewFold cmd vState.visible
      newState =
        Pair (max zero l')
             (min (max r'  -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                      (l' + BigInt.fromInt 400))
                  (cSys^._TotalSize))

  putVar { visible: newState } state.viewState

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  -- Blank out the track canvas and get its context
  trackCtx <- liftEff do
    {width, height} <- Canvas.getCanvasDimensions canvases.track
    trackCtx <- getContext2D canvases.track
    Drawing.render trackCtx
      $ filled (fillColor white) $ rectangle 0.0 0.0 width height
    pure trackCtx

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
      pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      predB p = p.x - 10.0 > pxL'
             && p.x + 10.0 < pxR'
      predS s = s.width >= one
             && s.point.x - s.width > pxL'
             && s.point.x + s.width < pxR'

      shiftView x =
        void $ liftEff $ Canvas.translate { translateX: x, translateY: zero } trackCtx

  -- Shift canvas so we render to the visible part
  shiftView (-offset)

  -- Make sure we unshift even if renderer is killed
  finally (shiftView offset) do

    for_ ts \track -> do

      for_ track \t -> do
        case t of
          Left {drawing, points}  -> do
            let points' = filter predB points
            liftEff $
              renderBatch canvases.buffer {drawing, points: points'} trackCtx

          Right gs -> do
            let gs' = filter predS gs
            liftEff $ foreachE gs' \s ->
              Drawing.render trackCtx
                $ Drawing.translate s.point.x s.point.y
                $ s.drawing

        -- delay to give the UI thread a moment
        delay (wrap 3.0)

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Process, Producer, connect, runProcess, ($$))
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, delay, finally, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, takeVar, tryTakeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn4, runEffFn4)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Filterable (filter)
import Data.Foldable (class Foldable, foldMap, for_, null)
import Data.Lens (to, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import FRP.Event (Event)
import Genetics.Browser.Track.Backend (Padding, RenderedTrack, browser, bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (BedFeature, GWASFeature, Annot, annotLegendTest, demoTracksBed, getAnnotations, getBedGenes, getGWAS, produceAnnots, produceGWAS, produceGenes)
import Genetics.Browser.Types (Bp(..), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (CoordSys, _TotalSize, coordSys, pairSize, scalePairBy, translatePairBy)
import Graphics.Canvas (CanvasElement, Context2D, getContext2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: forall eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

-- set an event to fire on the given button id

foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type ViewRange = Pair BigInt

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (ViewRange -> ViewRange)

updateViewFold :: UpdateView
               -> ViewRange
               -> ViewRange
updateViewFold uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `scalePairBy`  x
  ScrollView x -> iv `translatePairBy` x
  ModView f    -> f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

-- TODO handle normalization of view
-- TODO sync up graphical canvas-scrolling with actual browser viewstate
dragScroll :: Number
           -> BrowserCanvas
           -> AVar UpdateView
           -> Eff _ Unit
dragScroll width cnv av =
  let f = case _ of
        Left  {x,y} -> queueCmd av $ ScrollView $ g (-x)
        Right {x,y} -> scrollCanvas cnv.buffer cnv.track {x: -x, y: zero}
      g x = x / width
  in canvasDrag f cnv.overlay

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Number
        f dY = let d' = 10000.0
                   n = dY * d'
                   d = d' * 100.0
               in n / d

-- TODO differentiate scroll buffer & rendering buffer
type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Canvas.TranslateTransform
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim trackTT = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  -- Translate the origin of the Track canvas;
  -- useful to place the origin within the vertical padding and horizontal UI elements
  void $ Canvas.getContext2D track >>= Canvas.translate trackTT

  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

cSys :: CoordSys ChrId BigInt
cSys = coordSys mouseChrSizes

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "17103129"
      , Tuple "Y"   "9174469"
      ]

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , padding :: Padding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import timeFun :: forall eff a. (Unit -> a) -> Eff eff Unit

foreign import drawImageMany :: forall eff a.
                                EffFn4 eff
                                CanvasElement
                                Context2D
                                { width :: Number, height :: Number }
                                (Array Point)
                                Unit

renderBatch :: CanvasElement
            -> { drawing :: Drawing, points :: Array Point }
            -> Context2D
            -> Eff _ Unit
renderBatch buffer {drawing, points} ctx = do
  -- hardcoded glyph sizes for now.
  let r = 13.0
      d = r * 2.0
      dim = { width: 100.0, height: d }
                          -- width even more hardcoded to deal with long text!
  _ <- Canvas.setCanvasDimensions dim buffer
  bfrCtx <- Canvas.getContext2D buffer
  Drawing.render bfrCtx $ Drawing.translate r r drawing
  let img = Canvas.canvasElementToImageSource buffer
  runEffFn4 drawImageMany buffer ctx dim points

type BrowserState = { visible  :: ViewRange }
                    -- , rendered :: ViewRange }

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> Number
           -> BrowserCanvas
           -> { viewState   :: AVar BrowserState
              , viewCmds    :: AVar UpdateView
              , renderFiber :: AVar (Fiber _ Unit)}
           -> Aff _ _
renderLoop cSys browser trackDisplayWidth canvases state = forever do

  vState <- takeVar state.viewState

  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let scale = BigInt.toNumber (pairSize vState.visible) / trackDisplayWidth
      (Pair l _ ) = vState.visible
      offset = BigInt.toNumber l / scale
      tracks = browser.tracks vState.visible

  -- fork a new renderFiber
  renderFiber <- forkAff $ renderGlyphs vState.visible scale tracks canvases
  putVar renderFiber state.renderFiber

  liftEff $ do
    trackCtx   <- getContext2D canvases.track
    overlayCtx <- getContext2D canvases.overlay

    -- Shift canvas so we render to the visible part
    -- this shit ugly af tho, all of this gotta get redone~~
    void $ Canvas.withContext trackCtx do
      void $ Canvas.translate
        { translateX: (-offset), translateY: zero } trackCtx
      Drawing.render trackCtx $ browser.relativeUI vState.visible

    Drawing.render overlayCtx browser.fixedUI

  -- wait until UI has been clicked, view scrolled, etc.
  cmd <- takeVar state.viewCmds

      -- update view using received cmd, limiting view to coordsys
  let (Pair l' r') = updateViewFold cmd vState.visible
      newState =
        Pair (max zero l')
             (min (max r'  -- arbitrary minimum of 400 units shown, so things don't go too crazy when zoomed in
                      (l' + BigInt.fromInt 400))
                  (cSys^._TotalSize))

  putVar { visible: newState } state.viewState

renderGlyphs :: Pair BigInt
             -> Number
             -> List (Array RenderedTrack)
             -> BrowserCanvas
             -> Aff _ Unit
renderGlyphs vw@(Pair l _) viewScale ts canvases = do

  -- Blank out the track canvas and get its context
  trackCtx <- liftEff do
    {width, height} <- Canvas.getCanvasDimensions canvases.track
    trackCtx <- getContext2D canvases.track
    Drawing.render trackCtx
      $ filled (fillColor white) $ rectangle 0.0 0.0 width height
    pure trackCtx

  let offset = BigInt.toNumber l / viewScale
      vw'@(Pair pxL pxR) = map (\x -> (BigInt.toNumber x / viewScale)) vw

  -- Predicates to filter out glyphs that would not be visible on screen
     -- Hack to render more of the canvas just to be sure
      pxL' = pxL - (pxR - pxL)
      pxR' = pxR + (pxR - pxL)
      predB p = p.x - 10.0 > pxL'
             && p.x + 10.0 < pxR'
      predS s = s.width >= one
             && s.point.x - s.width > pxL'
             && s.point.x + s.width < pxR'

      shiftView x =
        void $ liftEff $ Canvas.translate { translateX: x, translateY: zero } trackCtx

  -- Shift canvas so we render to the visible part
  shiftView (-offset)

  -- Make sure we unshift even if renderer is killed
  finally (shiftView offset) do

    for_ ts \track -> do

      for_ track \t -> do
        case t of
          Left {drawing, points}  -> do
            let points' = filter predB points
            liftEff $
              renderBatch canvases.buffer {drawing, points: points'} trackCtx

          Right gs -> do
            let gs' = filter predS gs
            liftEff $ foreachE gs' \s ->
              Drawing.render trackCtx
                $ Drawing.translate s.point.x s.point.y
                $ s.drawing

        -- delay to give the UI thread a moment
        delay (wrap 3.0)

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av

       let new = sofar <> m

       putVar new av
       delay (wrap 20.0)

       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwasProd   <- traverse (produceGWAS cs) urls.gwas
  annotsProd <- traverse (produceAnnots cs) urls.annotations
  genesProd  <- traverse (produceGenes cs) urls.genes

  gwas        <- makeVar mempty
  annotations <- makeVar mempty
  genes       <- makeVar mempty

  let gwasProc :: Maybe (Process (Aff _) Unit)
      gwasProc   = (_ $$ chunkConsumer gwas)   <$> gwasProd
      annotsProc = (_ $$ chunkConsumer annotations) <$> annotsProd
      genesProc  = (_ $$ chunkConsumer genes)  <$> genesProd

  _ <- traverse forkAff (runProcess <$> gwasProc)
  _ <- traverse forkAff (runProcess <$> annotsProc)
  _ <- traverse forkAff (runProcess <$> genesProc)

  pure { gwas, annotations, genes }

runBrowser :: Conf -> Eff _ _
runBrowser config = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)

    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff do
        createBrowserCanvas
          el browserDimensions
          { translateX: vScaleWidth
          , translateY: zero }

  trackData <- do
    genes <- traverse (getBedGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: Pair BigInt
      initialView = Pair zero (cSys^._TotalSize)

  viewCmds <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmds
    btnZoom   0.10 viewCmds
    dragScroll trackWidth bCanvas viewCmds

  viewState <- makeVar { visible: initialView }

  renderFiber <- makeEmptyVar

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }
      s = config.score
      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }
      tracks = demoTracksBed vscale trackData
      mainBrowser = browser cSys browserDimensions config.padding {legend, vscale} tracks

  _ <- forkAff $ renderLoop cSys mainBrowser trackWidth bCanvas { viewCmds, viewState, renderFiber }

  pure unit

-- TODO do this parsing better. good enough for now, but jesus.
--              do it applicative. semiring or at least semigroup
parseConfig :: Json -> Either String Conf
parseConfig j = do
  obj <- note "Provide a JSON object as configuration" $ j ^? _Object
  browserHeight <-
    note "`browserHeight` should be a Number" $ obj ^? ix "browserHeight" <<< _Number

  padding <- do
    p <- note "`padding` should be an object" $ obj ^? ix "padding" <<< _Object
    vertical <-
      note "`padding.vertical` should be a Number" $ p ^? ix "vertical" <<< _Number
    horizontal <-
      note "`padding.horizontal` should be a Number" $ p ^? ix "horizontal" <<< _Number
    pure {vertical, horizontal}

  score <- do
    s <- note "`score` should be an object" $ obj ^? ix "score" <<< _Object
    min <-
      note "`score.min` should be a Number" $ s ^? ix "min" <<< _Number
    max <-
      note "`score.max` should be a Number" $ s ^? ix "max" <<< _Number
    sig <-
      note "`score.sig` should be a Number" $ s ^? ix "sig" <<< _Number

    pure {min, max, sig}

  urls <- do
    u <- note "`urls` should be an object" $ obj ^? ix "urls" <<< _Object

    let gwas = u ^? ix "gwas" <<< _String
        annotations = u ^? ix "annotations" <<< _String
        genes = u ^? ix "genes" <<< _String

    pure {gwas, annotations, genes}

  pure {browserHeight, padding, score, urls}

initBrowser :: Json -> Eff _ _
initBrowser conf = do

  case parseConfig conf of
    Left err -> unsafeCrashWith err
    Right c  -> runBrowser c


Increase the number of times to retry loading

module IdePurescript.VSCode.Main where

import Prelude
import IdePurescript.Completion as C
import PscIde.Command as Command
import VSCode.Notifications as Notify
import Control.Monad.Aff (later', attempt, Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, fromAff)
import Data.Array (filter, notElem, uncons)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readArray, readBoolean, readInt, readString)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, regex, split)
import Data.String.Regex.Flags (noFlags)
import Data.Traversable (traverse)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..))
import IdePurescript.Modules (ImportResult(FailedImport, AmbiguousImport, UpdatedImports), State, addExplicitImport, getModulesForFile, getQualModule, getUnqualActiveModules, initialModulesState)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getLoadedModules, getType)
import IdePurescript.PscIdeServer (Notify, ErrorLevel(Error, Warning, Info, Success))
import IdePurescript.PscIdeServer (startServer', QuitCallback, ServerEff) as P
import IdePurescript.Tokens (identifierAtPoint)
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Editor (GetText)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Symbols (SymbolInfo, SymbolQuery(..), getDefinition, getSymbols)
import IdePurescript.VSCode.Types (MainEff, liftEffM)
import PscIde (load) as P
import PscIde (NET)
import PscIde.Command (TypeInfo(..))
import Unsafe.Coerce (unsafeCoerce)
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Location (Location)
import VSCode.Position (mkPosition)
import VSCode.Range (mkRange, Range)
import VSCode.TextDocument (TextDocument, getPath, getText)
import VSCode.TextEditor (setTextViaDiff, getDocument)
import VSCode.Window (getActiveTextEditor, setStatusBarMessage, WINDOW)
import VSCode.Workspace (rootPath, getValue, getConfiguration, WORKSPACE)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  void $ runAff ignoreError ignoreError $ do
    state <- getModulesForFile port path text
    liftEff $ writeRef modulesStateRef state

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
getCompletions port state line' char getTextInRange = do
  line <- getTextInRange line' 0 line' char
  let getQualifiedModule = (flip getQualModule) state
  config <- getConfiguration "purescript"
  autoCompleteAllModules <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAllModules"
  fromAff $ do
    modules <- if autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
    suggestions <- C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main } }
    pure $ convert <$> suggestions
  where
    -- TODO change the types here and pull in suggestion handling into PS
    convert (ModuleSuggestion { text, suggestType, prefix }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': text, identifier: text, module': text, expandedType: Just text, definedAt: Nothing, documentation: Nothing }, prefix }
    convert (IdentSuggestion { mod, identifier, qualifier, suggestType, prefix, valueType }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': valueType, identifier, module': mod, expandedType: Just valueType, definedAt: Nothing, documentation: Nothing }, prefix }

    convertSuggest = case _ of
      Module -> "Module"
      Value -> "Value"
      Function -> "Function"
      Type -> "Type"

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    text <- getTextInRange line 0 line (char + 100)
    case identifierAtPoint text char of
      Just { word, qualifier } -> fromAff do
        ty <- getType port word state.main qualifier (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
        let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
        pure $ toNullable marked
      Nothing -> fromAff $ pure $ toNullable Nothing

startServer' :: forall eff eff'. String -> Int -> String -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Aff (P.ServerEff (workspace :: WORKSPACE | eff)) { port:: Maybe Int, quit:: P.QuitCallback eff' }
startServer' server _port root cb = do
  config <- liftEff $ getConfiguration "purescript"
  useNpmPath <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
  packagePath <- liftEff $ either (const "bower_components") id <<< runExcept <<< readString <$> getValue config "packagePath"
  P.startServer' root server useNpmPath ["src/**/*.purs", packagePath <> "/**/*.purs"] cb

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String, range :: Range }
  }
type VSBuildResult =
  { success :: Boolean
  , diagnostics :: Array FileDiagnostic
  , quickBuild :: Boolean
  , file :: String
  }

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  errors' <- liftEff $ censorWarnings errors
  pure $ { success, diagnostics: toDiagnostic' errors', quickBuild: true, file: filename }

toDiagnostic' :: ErrorResult -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

type ErrorResult = { warnings :: Array PscError, errors :: Array PscError }

censorWarnings :: forall eff. ErrorResult -> Eff (MainEff eff) ErrorResult
censorWarnings { warnings, errors } = do
  config <- liftEff $ getConfiguration "purescript"
  censorCodes <- getValue config "censorWarnings"
  let codes = either (const []) id $ runExcept $ readArray censorCodes >>= traverse readString
  let getCode (PscError { errorCode }) = errorCode
  pure $ { warnings: filter (flip notElem codes <<< getCode) warnings, errors }

build' :: forall eff. Notify (MainEff eff) -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEffM $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ showStatus Building
      config <- liftEff $ getConfiguration "purescript"
      useNpmDir <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
      res <- build { command: Command cmd args, directory, useNpmDir }
      errors <- liftEff $ censorWarnings res.errors
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' errors, quickBuild: false, file: "" }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [], quickBuild: false, file: "" }

addCompletionImport :: forall eff. (Ref State) -> Int -> Array Foreign -> Aff (MainEff eff) Unit
addCompletionImport stateRef port args = case args of
  [ line, char, item ] -> case runExcept $ readInt line, runExcept $ readInt char of
    Right line', Right char' -> do
      let item' = (unsafeCoerce item) :: Command.TypeInfo
      Command.TypeInfo { identifier, module' } <- pure item'
      ed <- liftEffM $ getActiveTextEditor
      case ed of
        Just ed' -> do
          let doc = getDocument ed'
          text <- liftEffM $ getText doc
          path <- liftEffM $ getPath doc
          state <- liftEffM $ readRef stateRef
          { state: newState, result: output} <- addExplicitImport state port path text (Just module') identifier
          liftEffM $ writeRef stateRef newState
          case output of
            UpdatedImports out -> void $ setTextViaDiff ed' out
            AmbiguousImport opts -> liftEffM $ log "Found ambiguous imports"
            FailedImport -> liftEffM $ log "Failed to import"
          pure unit
        Nothing -> pure unit
      pure unit
    _, _ -> liftEffM $ log "Wrong argument type"
  _ -> liftEffM $ log "Wrong command arguments"

main :: forall eff. Eff (MainEff eff)
  { activate :: Eff (MainEff eff) (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
  , getSymbols :: EffFn1 (MainEff eff) String (Promise (Array SymbolInfo))
  , getSymbolsForDoc :: EffFn1 (MainEff eff) TextDocument (Promise (Array SymbolInfo))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) (\_ -> f)
      cmdWithArgs s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify (MainEff eff)
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff

  let startPscIdeServer =
        do
          config <- liftEffMM $ getConfiguration "purescript"
          server <- liftEffMM $ either (const "psc-ide-server") id <<< runExcept <<< readString <$> getValue config "pscIdeServerExe"
          port' <- liftEffMM $ either (const 4242) id <<< runExcept <<< readInt <$> getValue config "pscIdePort"
          rootPath <- liftEffMM rootPath
          -- TODO pass in port just when explicitly defined
          startRes <- startServer' server port' rootPath showError
          retry 6 case startRes of
            { port: Just port, quit } -> do
              P.load port [] []
              liftEffMM $ do
                writeRef deactivateRef quit
                writeRef portRef port
            _ -> pure unit
        where
          retry :: Int -> Aff (MainEff eff) Unit -> Aff (MainEff eff) Unit
          retry n a | n > 0 = do
            res <- attempt a
            case res of
              Right r -> pure r
              Left err -> do
                liftEff $ log $ "Retrying starting server after 500ms: " <> show err
                later' 500 $ retry (n - 1) a
          retry _ a = a

      restart :: Eff (MainEff eff) Unit
      restart = do
        deactivate
        void $ runAff ignoreError ignoreError $ startPscIdeServer

  let initialise = fromAff $ do
        startPscIdeServer
        liftEffMM do
          cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
          cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
          cmd "caseSplit" $ readRef portRef >>= caseSplit
          cmd "addClause" $ readRef portRef >>= addClause
          cmd "restartPscIde" $ restart
          cmdWithArgs "addCompletionImport" $ \args -> do
            port <- readRef portRef
            config <- getConfiguration "purescript"
            autocompleteAddImport <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAddImport"
            when autocompleteAddImport $
              void $ runAff ignoreError ignoreError $ addCompletionImport modulesState port args

  pure
    {
      activate: initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , getSymbols: mkEffFn1 $ \query -> getSymbols modulesState portRef $ WorkspaceSymbolQuery query
    , getSymbolsForDoc: mkEffFn1 $ \document -> getSymbols modulesState portRef $ FileSymbolQuery document
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }

module IdePurescript.VSCode.Main where

import Prelude
import IdePurescript.Completion as C
import PscIde.Command as Command
import VSCode.Notifications as Notify
import Control.Monad.Aff (later', attempt, Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, fromAff)
import Data.Array (filter, notElem, uncons)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readArray, readBoolean, readInt, readString)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, regex, split)
import Data.String.Regex.Flags (noFlags)
import Data.Traversable (traverse)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..))
import IdePurescript.Modules (ImportResult(FailedImport, AmbiguousImport, UpdatedImports), State, addExplicitImport, getModulesForFile, getQualModule, getUnqualActiveModules, initialModulesState)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getLoadedModules, getType)
import IdePurescript.PscIdeServer (Notify, ErrorLevel(Error, Warning, Info, Success))
import IdePurescript.PscIdeServer (startServer', QuitCallback, ServerEff) as P
import IdePurescript.Tokens (identifierAtPoint)
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Editor (GetText)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Symbols (SymbolInfo, SymbolQuery(..), getDefinition, getSymbols)
import IdePurescript.VSCode.Types (MainEff, liftEffM)
import PscIde (load) as P
import PscIde (NET)
import PscIde.Command (TypeInfo(..))
import Unsafe.Coerce (unsafeCoerce)
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Location (Location)
import VSCode.Position (mkPosition)
import VSCode.Range (mkRange, Range)
import VSCode.TextDocument (TextDocument, getPath, getText)
import VSCode.TextEditor (setTextViaDiff, getDocument)
import VSCode.Window (getActiveTextEditor, setStatusBarMessage, WINDOW)
import VSCode.Workspace (rootPath, getValue, getConfiguration, WORKSPACE)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  void $ runAff ignoreError ignoreError $ do
    state <- getModulesForFile port path text
    liftEff $ writeRef modulesStateRef state

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
getCompletions port state line' char getTextInRange = do
  line <- getTextInRange line' 0 line' char
  let getQualifiedModule = (flip getQualModule) state
  config <- getConfiguration "purescript"
  autoCompleteAllModules <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAllModules"
  fromAff $ do
    modules <- if autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
    suggestions <- C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main } }
    pure $ convert <$> suggestions
  where
    -- TODO change the types here and pull in suggestion handling into PS
    convert (ModuleSuggestion { text, suggestType, prefix }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': text, identifier: text, module': text, expandedType: Just text, definedAt: Nothing, documentation: Nothing }, prefix }
    convert (IdentSuggestion { mod, identifier, qualifier, suggestType, prefix, valueType }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': valueType, identifier, module': mod, expandedType: Just valueType, definedAt: Nothing, documentation: Nothing }, prefix }

    convertSuggest = case _ of
      Module -> "Module"
      Value -> "Value"
      Function -> "Function"
      Type -> "Type"

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    text <- getTextInRange line 0 line (char + 100)
    case identifierAtPoint text char of
      Just { word, qualifier } -> fromAff do
        ty <- getType port word state.main qualifier (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
        let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
        pure $ toNullable marked
      Nothing -> fromAff $ pure $ toNullable Nothing

startServer' :: forall eff eff'. String -> Int -> String -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Aff (P.ServerEff (workspace :: WORKSPACE | eff)) { port:: Maybe Int, quit:: P.QuitCallback eff' }
startServer' server _port root cb = do
  config <- liftEff $ getConfiguration "purescript"
  useNpmPath <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
  packagePath <- liftEff $ either (const "bower_components") id <<< runExcept <<< readString <$> getValue config "packagePath"
  P.startServer' root server useNpmPath ["src/**/*.purs", packagePath <> "/**/*.purs"] cb

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String, range :: Range }
  }
type VSBuildResult =
  { success :: Boolean
  , diagnostics :: Array FileDiagnostic
  , quickBuild :: Boolean
  , file :: String
  }

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  errors' <- liftEff $ censorWarnings errors
  pure $ { success, diagnostics: toDiagnostic' errors', quickBuild: true, file: filename }

toDiagnostic' :: ErrorResult -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

type ErrorResult = { warnings :: Array PscError, errors :: Array PscError }

censorWarnings :: forall eff. ErrorResult -> Eff (MainEff eff) ErrorResult
censorWarnings { warnings, errors } = do
  config <- liftEff $ getConfiguration "purescript"
  censorCodes <- getValue config "censorWarnings"
  let codes = either (const []) id $ runExcept $ readArray censorCodes >>= traverse readString
  let getCode (PscError { errorCode }) = errorCode
  pure $ { warnings: filter (flip notElem codes <<< getCode) warnings, errors }

build' :: forall eff. Notify (MainEff eff) -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEffM $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ showStatus Building
      config <- liftEff $ getConfiguration "purescript"
      useNpmDir <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
      res <- build { command: Command cmd args, directory, useNpmDir }
      errors <- liftEff $ censorWarnings res.errors
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' errors, quickBuild: false, file: "" }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [], quickBuild: false, file: "" }

addCompletionImport :: forall eff. (Ref State) -> Int -> Array Foreign -> Aff (MainEff eff) Unit
addCompletionImport stateRef port args = case args of
  [ line, char, item ] -> case runExcept $ readInt line, runExcept $ readInt char of
    Right line', Right char' -> do
      let item' = (unsafeCoerce item) :: Command.TypeInfo
      Command.TypeInfo { identifier, module' } <- pure item'
      ed <- liftEffM $ getActiveTextEditor
      case ed of
        Just ed' -> do
          let doc = getDocument ed'
          text <- liftEffM $ getText doc
          path <- liftEffM $ getPath doc
          state <- liftEffM $ readRef stateRef
          { state: newState, result: output} <- addExplicitImport state port path text (Just module') identifier
          liftEffM $ writeRef stateRef newState
          case output of
            UpdatedImports out -> void $ setTextViaDiff ed' out
            AmbiguousImport opts -> liftEffM $ log "Found ambiguous imports"
            FailedImport -> liftEffM $ log "Failed to import"
          pure unit
        Nothing -> pure unit
      pure unit
    _, _ -> liftEffM $ log "Wrong argument type"
  _ -> liftEffM $ log "Wrong command arguments"

main :: forall eff. Eff (MainEff eff)
  { activate :: Eff (MainEff eff) (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
  , getSymbols :: EffFn1 (MainEff eff) String (Promise (Array SymbolInfo))
  , getSymbolsForDoc :: EffFn1 (MainEff eff) TextDocument (Promise (Array SymbolInfo))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) (\_ -> f)
      cmdWithArgs s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify (MainEff eff)
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff

  let startPscIdeServer =
        do
          config <- liftEffMM $ getConfiguration "purescript"
          server <- liftEffMM $ either (const "psc-ide-server") id <<< runExcept <<< readString <$> getValue config "pscIdeServerExe"
          port' <- liftEffMM $ either (const 4242) id <<< runExcept <<< readInt <$> getValue config "pscIdePort"
          rootPath <- liftEffMM rootPath
          -- TODO pass in port just when explicitly defined
          startRes <- startServer' server port' rootPath showError
          retry case startRes of
            { port: Just port, quit } -> do
              P.load port [] []
              liftEffMM $ do
                writeRef deactivateRef quit
                writeRef portRef port
            _ -> pure unit
        where
          retry :: Aff (MainEff eff) Unit -> Aff (MainEff eff) Unit
          retry a = do
            res <- attempt a
            case res of
              Right r -> pure r
              Left err -> do
                liftEff $ log $ "Retrying starting server after 500ms: " <> show err
                later' 500 a

      restart :: Eff (MainEff eff) Unit
      restart = do
        deactivate
        void $ runAff ignoreError ignoreError $ startPscIdeServer

  let initialise = fromAff $ do
        startPscIdeServer
        liftEffMM do
          cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
          cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
          cmd "caseSplit" $ readRef portRef >>= caseSplit
          cmd "addClause" $ readRef portRef >>= addClause
          cmd "restartPscIde" $ restart
          cmdWithArgs "addCompletionImport" $ \args -> do
            port <- readRef portRef
            config <- getConfiguration "purescript"
            autocompleteAddImport <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAddImport"
            when autocompleteAddImport $
              void $ runAff ignoreError ignoreError $ addCompletionImport modulesState port args

  pure
    {
      activate: initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , getSymbols: mkEffFn1 $ \query -> getSymbols modulesState portRef $ WorkspaceSymbolQuery query
    , getSymbolsForDoc: mkEffFn1 $ \document -> getSymbols modulesState portRef $ FileSymbolQuery document
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }


Start making a navbar

Start making a navbar

module View where

import Prelude (const, show)
import Pux.Html
import Pux.Html.Events (onClick)
import Pux.Html.Attributes
import Types (State, Action(..))

navbar :: State -> Html Action
navbar state =
  div
    [ className "navbar navbar-default" ]
    [ div
        [ className "container-fluid" ]
        [ div
            [ className "navbar-header" ]
            [ a [ className "navbar-brand", href "#" ] [ text "Veilig" ]
            ]
        ]
    ]

view :: State -> Html Action
view state =
  div
    []
    [ navbar state
    , button [ onClick (const Increment) ] [ text "Increment" ]
    , span [] [ text (show state) ]
    , button [ onClick (const Decrement) ] [ text "Decrement" ]
    ]

module View where

import Prelude
import Pux.Html (Html, text, button, span, div)
import Pux.Html.Events (onClick)

import Types

view :: State -> Html Action
view count =
  div
    []
    [ button [ onClick (const Increment) ] [ text "Increment" ]
    , span [] [ text (show count) ]
    , button [ onClick (const Decrement) ] [ text "Decrement" ]
    ]