clean up UI code & re-enable SNP/annot info box

module Genetics.Browser.UI where

import Prelude

import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error, throw)
import DOM.Classy.HTMLElement (appendChild, setId) as DOM
import DOM.Classy.ParentNode (toParentNode)
import DOM.Event.KeyboardEvent (key) as DOM
import DOM.Event.Types (KeyboardEvent)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Document (createElement, documentElement) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, ElementId)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, foldMap, length, null)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Record.Extra (eqRecord)
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant, case_, inj)
import Data.Variant as V
import Genetics.Browser (LegendConfig, Peak, VScale, pixelSegments)
import Genetics.Browser.Canvas (BrowserCanvas, BrowserContainer(..), Renderable, TrackPadding, _Dimensions, _Track, browserCanvas, browserClickHandler, browserContainer, browserOnClick, debugBrowserCanvas, dragScroll, getDimensions, getLayers, renderBrowser, setBrowserCanvasSize, setBrowserContainerSize, setElementStyle, wheelZoom, zIndexLayers)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(CoordSysView), _TotalSize, coordSys, normalizeView, pairSize, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, SNPConfig, AnnotationsConfig, addDemoLayers, annotationsForScale, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
import Genetics.Browser.Layer (Component(..), Layer(..), browserSlots)
import Genetics.Browser.Types (ChrId(ChrId), _NegLog10, _prec)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)

foreign import windowInnerSize :: ∀ e. Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: ∀ e.
                              String
                           -> Eff e Unit
                           -> Eff e Unit

foreign import keydownEvent :: ∀ e.
                                Element
                             -> (KeyboardEvent -> Eff e Unit)
                             -> Eff e Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ∀ e.
                              ({ width  :: Number
                               , height :: Number } -> Eff e Unit)
                           -> Eff e Unit

-- | The value returned by the function that initializes the genome browser;
-- | provides an interface to the running browser instance.
type BrowserInterface e a
  = { getView          :: Aff e CoordSysView
    , getBrowserCanvas :: Aff e BrowserContainer
    , lastOverlaps     :: Eff e (Number -> Point -> Array a)
    , queueCommand     :: Variant UICmdR -> Aff e Unit
    , queueUpdateView  :: UpdateView -> Eff e Unit
    }

-- | Creates the browser using the provided initial data, returning
-- | a BrowserInterface for reading state & sending commands to it
initializeBrowser :: ∀ r.
                     CoordSys _ _
                  -> { snps        :: Number -> CoordSysView -> Eff _ Unit
                     , annotations :: Number -> CoordSysView -> Eff _ Unit
                     , chrs        :: Number -> CoordSysView -> Eff _ Unit
                     , overlaps    :: Eff _ (Number -> Point -> Array (SNP ()))
                     , fixedUI     :: Eff _ Unit | r}
                  -> CoordSysView
                  -> BrowserContainer
                  -> Aff _ (BrowserInterface _ (SNP ()))
initializeBrowser cSys renderFuns initView bc = do

  renderFiberVar <- AVar.makeEmptyVar

  viewVar <- AVar.makeVar initView
  bcVar <- AVar.makeVar bc

  uiCmdVar <- AVar.makeEmptyVar
  lastOverlapsVar <- AVar.makeEmptyVar

  let getView = AVar.readVar viewVar
      getBrowserCanvas = AVar.readVar bcVar
      queueCommand = flip AVar.putVar uiCmdVar
      lastOverlaps = renderFuns.overlaps

    -- hardcoded timeout for now
  queueUpdateView <- uiViewUpdate cSys (wrap 100.0) {view: viewVar, uiCmd: uiCmdVar}

  let mainLoop = do
        uiCmd <- AVar.takeVar uiCmdVar
        case_ # V.on _render (\_ -> pure unit)
              # V.on _docResize (\_ -> pure unit)
              -- # V.on _docResize (\ {width} -> do
              --         canvas <- AVar.takeVar bcVar
              --         {height} <- _.size <$> getDimensions canvas
              --         -- let {height} = dims.size
              --         _ <- liftEff $ setBrowserContainerSize {width, height} canvas
              --         AVar.putVar canvas bcVar
              --         queueCommand $ inj _render unit
              --         mainLoop)
              $ uiCmd

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

        csView <- getView
        canvas <- getBrowserCanvas
        -- toRender <- liftEff $ renderFuns.snps csView
        -- toRender <- drawCachedBrowser canvas csView

        currentDims <- getDimensions canvas

        let trackDims = _.padded $ browserSlots currentDims
            currentScale = viewScale trackDims.size csView
            offset = scaleToScreen  currentScale (Pair.fst $ unwrap $ csView)

                          -- offset the click by the current canvas translation
        -- _ <- AVar.tryTakeVar lastOverlapsVar
        -- AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
        --                      in unsafeCoerce $ unit) lastOverlapsVar
                             -- in { snps: toRender.tracks.snps.overlaps n r' }) lastOverlapsVar

        -- fork a new renderFiber
        renderFiber <- forkAff $ liftEff do
          log $ "rendering with offset: " <> show offset
          log <<< show =<< Map.keys <$> getLayers bc

          renderFuns.chrs        offset csView
          renderFuns.annotations offset csView
          renderFuns.snps        offset csView
          renderFuns.fixedUI

        AVar.putVar renderFiber renderFiberVar

        mainLoop

  _ <- forkAff mainLoop

  queueCommand $ inj _render unit

  pure { getView
       , getBrowserCanvas
       , lastOverlaps
       , queueCommand
       , queueUpdateView }

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

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
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

queueCmd :: ∀ a. AVar a -> a -> Eff _ Unit
queueCmd av cmd = launchAff_ $ AVar.putVar cmd av

-- | Provided with the AVar containing the view state (which is updated atomically)
-- | and the UICmd AVar queue (which is only written to),
-- | return a function that queues view updates using the provided timeout.
uiViewUpdate :: ∀ r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view  :: AVar CoordSysView
                , uiCmd :: AVar (Variant UICmdR) | r }
             -> Aff _ (UpdateView -> Eff _ Unit)
uiViewUpdate cs timeout { view, uiCmd } = do
  viewCmd <- AVar.makeEmptyVar

  curCmdVar <- AVar.makeVar (ModView id)

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- AVar.takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

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

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"

            vr <- AVar.takeVar view
            let vr' = normView $ updateViewFold cmd' vr
            AVar.putVar vr' view

            AVar.putVar (inj _render unit) uiCmd
            AVar.takeVar curCmdVar *> AVar.putVar mempty curCmdVar

        loop' updater'

  _ <- forkAff $ loop' (pure unit)

  pure $ queueCmd viewCmd

btnUI :: { scrollMod :: Number, zoomMod :: Number }
      -> (UpdateView -> Eff _ Unit)
      -> Eff _ Unit
btnUI mods cb = do
  buttonEvent "scrollLeft"  $ cb $ ScrollView     (-mods.scrollMod)
  buttonEvent "scrollRight" $ cb $ ScrollView       mods.scrollMod
  buttonEvent "zoomOut"     $ cb $ ZoomView $ 1.0 + mods.zoomMod
  buttonEvent "zoomIn"      $ cb $ ZoomView $ 1.0 - mods.zoomMod

keyUI :: ∀ r.
         Element
      -> { scrollMod :: Number | r }
      -> (UpdateView -> Eff _ Unit)
      -> Eff _ Unit
keyUI el mods cb = keydownEvent el f
  where f ke = case DOM.key ke of
          "ArrowLeft"  -> cb $ ScrollView (-mods.scrollMod)
          "ArrowRight" -> cb $ ScrollView   mods.scrollMod
          _ -> pure unit

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

debugView :: BrowserInterface _ _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- s.getView
         liftEff do
           log $ "CoordSysView: " <> show (map BigInt.toString $ unwrap view)
           setWindow name $ (\(Pair l r) -> {l,r}) $ unwrap view

  let set lr = s.queueUpdateView
               $ ModView $ const (BigInt.fromNumber <$> Pair lr.l lr.r)

  pure {get, set}

browserCache
  :: ∀ a b.
     (BrowserCanvas
      -> CoordSysView
      -> { tracks :: { snps :: a
                     , annotations :: b }
         , relativeUI :: Drawing
         , fixedUI :: Drawing })
     -> Aff _ (BrowserCanvas
               -> CoordSysView
               -> Aff _ ({ tracks :: { snps :: a
                                     , annotations :: b }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing }))
browserCache f = do
  bcDim <- AVar.makeEmptyVar
  viewSize <- AVar.makeEmptyVar

  lastPartial <- AVar.makeEmptyVar
  lastFinal <- AVar.makeEmptyVar

  pure \bc csv -> do

    let newBCDim = bc ^. _Dimensions
    oldBCDim <- AVar.tryTakeVar bcDim
    AVar.putVar newBCDim bcDim

    oldPartial <- AVar.tryTakeVar lastPartial

    partial <- case oldBCDim, oldPartial of
      Just d, Just o -> do
        let changed = not $ d `eqRecord` newBCDim
        liftEff $ log $ "BrowserCanvas changed? " <> (show changed)
        -- remove the cached final output value on canvas resize,
        -- since we need to recalculate everything
        when changed (void $ AVar.tryTakeVar lastFinal)
        pure $ if d `eqRecord` newBCDim then o else f bc

      _, _ -> do
        liftEff $ log "Cache was empty! Recalculating all"
        _ <- AVar.tryTakeVar lastFinal
        pure $ f bc

    AVar.putVar partial lastPartial

    let newViewSize = pairSize $ unwrap csv
    oldViewSize <- AVar.tryTakeVar viewSize
    AVar.putVar newViewSize viewSize

    oldFinal <- AVar.tryTakeVar lastFinal

    let output = case oldViewSize, oldFinal of
          Just vs, Just o -> if newViewSize == vs then o else partial csv
          _, _ -> partial csv

    AVar.putVar output lastFinal
    pure output

printSNPInfo :: ∀ r. Array (SNP r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5
  log $ "showing " <> show m <> " out of " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) (log <<< unsafeCoerce)

wrapWith :: String -> String -> String
wrapWith tag x =
  "<"<> tag <>">" <> x <> "</"<> tag <>">"

snpHTML :: ∀ r.
           SNP r
        -> String
snpHTML {position, feature} = wrapWith "div" contents
  where contents = foldMap (wrapWith "p")
            [ "SNP: "    <> feature.name
            , "Chr: "    <> show feature.chrId
            , "Pos: "    <> show (Pair.fst position)
            , "-log10: " <> feature.score ^. _NegLog10 <<< _Newtype <<< _prec 4
            ]

peakHTML :: ∀ a.
            (a -> String)
         -> Peak _ _ a
         -> String
peakHTML disp peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> disp head
    Just {head, tail}     ->
      wrapWith "div" $ wrapWith "p"
        $ show (length tail + 1) <> " annotations"

-- | Given a function to transform the data in the annotation's "rest" field
-- | to text (or Nothing if the field should not be displayed), produce a
-- | function that generates HTML from annotations
annotationHTML :: (AnnotationField -> Maybe String)
                -> Annotation () -> String
annotationHTML disp {feature} = wrapWith "div" contents
  where url = fromMaybe "No URL"
              $ map (\a -> "URL: <a target='_blank' href='"
                           <> a <> "'>" <> a <> "") feature.url

        name = fromMaybe ("Annotated SNP: " <> feature.name)
                         (("Gene: " <> _) <$> feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        contents = foldMap (wrapWith "p")
          $ [ name
            , url
            ] <> (filterMap disp
                  $ Array.fromFoldable feature.rest)

-- | Shows all data in "rest" using the default showAnnotationField (which uses unsafeCoerce)
annotationHTMLAll :: Annotation () -> String
annotationHTMLAll =
  annotationHTML (pure <<< showAnnotationField)

annotationHTMLDefault :: Annotation () -> String
annotationHTMLDefault = annotationHTML \x -> pure case x of
  {field: "p_lrt", value} ->
     "p_lrt: " <> (unsafeCoerce value) ^. _NegLog10 <<< _Newtype <<< _prec 4
  fv -> showAnnotationField fv

-- | Example HTML generator that only shows the "anno" field
annotationHTMLAnnoOnly :: Annotation () -> String
annotationHTMLAnnoOnly = annotationHTML disp
  where disp fv
          | fv.field == "anno" = pure $ showAnnotationField fv
          | otherwise          = Nothing

foreign import initDebugDiv :: ∀ e. Number -> Eff e Unit
foreign import setDebugDivVisibility :: ∀ e. String -> Eff e Unit
foreign import setDebugDivPoint :: ∀ e. Point -> Eff e Unit

foreign import setElementContents :: ∀ e. Element -> String -> Eff e Unit

data InfoBoxF
  = IBoxShow
  | IBoxHide
  | IBoxSetY Int
  | IBoxSetX Int
  | IBoxSetContents String

derive instance genericInfoBoxF :: Generic InfoBoxF _

instance showInfoBoxF :: Show InfoBoxF where
  show = genericShow

updateInfoBox :: Element -> InfoBoxF -> Eff _ Unit
updateInfoBox el cmd =
  case cmd of
    IBoxShow ->
      setElementStyle el "visibility" "visible"
    IBoxHide ->
      setElementStyle el "visibility" "hidden"
    (IBoxSetX x)    ->
      setElementStyle el "left" $ show x <> "px"
    (IBoxSetY y)    ->
      setElementStyle el "top"  $ show y <> "px"
    (IBoxSetContents html) ->
      setElementContents el html

infoBoxId :: ElementId
infoBoxId = wrap "infoBox"

initInfoBox :: Eff _ (InfoBoxF -> Eff _ Unit)
initInfoBox = do
  doc <- map DOM.htmlDocumentToDocument
           $ DOM.document =<< DOM.window
  el <- DOM.createElement "div" doc

  DOM.setId infoBoxId el

  DOM.documentElement doc >>= case _ of
    Nothing -> throw "Couldn't find document body!"
    Just docBody -> void $ DOM.appendChild el docBody

  pure $ updateInfoBox el

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

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  cmdInfoBox <- liftEff $ initInfoBox

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

  trackData <-
    {genes:_, snps:_, annotations:_}
    <$> foldMap (getGenes       cSys) config.urls.genes
    <*> foldMap (getSNPs        cSys) config.urls.snps
    <*> foldMap (getAnnotations cSys) config.urls.annotations

  render <- liftEff
            $ addDemoLayers cSys config trackData bc

  browser <-
    initializeBrowser cSys render (wrap $ Pair zero (cSys^._TotalSize)) bc

  liftEff do
    resizeEvent \d ->
      launchAff_ $ browser.queueCommand $ inj _docResize d

    let mods = { scrollMod: 0.05, zoomMod: 0.1 }

    btnUI mods browser.queueUpdateView

    -- keyUI (unsafeCoerce $ (unwrap bc).staticOverlay)
    --       mods browser.queueUpdateView

    dragScroll bc \ {x,y} ->
      -- only do anything when scrolling at least a pixel
      when (Math.abs x >= one) do
        trackDims <- _.padded <<< browserSlots <$> getDimensions bc
        browser.queueUpdateView
         $ ScrollView $ (-x) / trackDims.size.width

    let scrollZoomScale = 0.06
    wheelZoom bc \dY ->
       browser.queueUpdateView
         $ ZoomView $ 1.0 + scrollZoomScale * dY

  liftEff do
    let sigSnps = filterSig config.score trackData.snps
        annotAround pks snp =
          Array.find (\a -> a.covers `pairsOverlap` snp.position)
            =<< Map.lookup snp.feature.chrId pks

        glyphClick :: _
        glyphClick p = launchAff_ do
          v  <- browser.getView
          bc <- browser.getBrowserCanvas

          trackDims <- _.padded <<< browserSlots <$> getDimensions bc
          let segs = pixelSegments { segmentPadding: 12.0 } cSys trackDims.size v
              annoPeaks = annotationsForScale cSys sigSnps
                            trackData.annotations segs

          lastOverlaps' <- liftEff $ browser.lastOverlaps
          liftEff do
            let clicked = (lastOverlaps' clickRadius p)
            printSNPInfo clicked
            case Array.head clicked of
              Nothing -> cmdInfoBox IBoxHide
              Just g  -> do
                cmdInfoBox IBoxShow
                cmdInfoBox $ IBoxSetX $ Int.round p.x
                cmdInfoBox $ IBoxSetContents
                  $ snpHTML g
                  <> foldMap (peakHTML annotationHTMLDefault) (annotAround annoPeaks g)

    browserClickHandler bc
      $ Padded 5.0 glyphClick

  pure unit

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

type Conf =
  { browserHeight :: Number
  , trackPadding :: TrackPadding
  , score :: { min :: Number, max :: Number, sig :: Number }
  , urls :: DataURLs
  , snpsConfig        :: SNPConfig
  , annotationsConfig :: AnnotationsConfig
  , legend :: LegendConfig ()
  , vscale :: VScale ()
  }

foreign import setWindow :: ∀ e a. String -> a -> Eff e Unit

main :: Foreign -> Eff _ _
main rawConfig = do

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

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          -- bc <- browserCanvas dimensions c.trackPadding el
          bc <- browserContainer dimensions c.trackPadding el

          -- debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: ∀ 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 <- AVar.takeVar av
      AVar.putVar (sofar <> m) av
      delay (wrap 20.0)
      pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: ∀ a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- AVar.makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | 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
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes }
-}

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"   "171031299"
      , Tuple "Y"   "91744698"
      ]

module Genetics.Browser.UI where

import Prelude

import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error, throw)
import DOM.Classy.HTMLElement (appendChild, setId) as DOM
import DOM.Classy.ParentNode (toParentNode)
import DOM.Event.KeyboardEvent (key) as DOM
import DOM.Event.Types (KeyboardEvent)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Document (createElement, documentElement) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, ElementId)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, foldMap, length, null)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Record.Extra (eqRecord)
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (Variant, case_, inj)
import Data.Variant as V
import Genetics.Browser (LegendConfig, Peak, RenderedTrack, VScale, pixelSegments)
import Genetics.Browser.Canvas (BrowserCanvas, BrowserContainer(..), Renderable, TrackPadding, _Dimensions, _Track, browserCanvas, browserClickHandler, browserContainer, browserOnClick, debugBrowserCanvas, dragScroll, getDimensions, getLayers, renderBrowser, setBrowserCanvasSize, setBrowserContainerSize, setElementStyle, wheelZoom, zIndexLayers)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(CoordSysView), _TotalSize, coordSys, normalizeView, pairSize, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, SNPConfig, AnnotationsConfig, addDemoLayers, annotationsForScale, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
import Genetics.Browser.Layer (Component(..), Layer(..), browserSlots)
import Genetics.Browser.Types (ChrId(ChrId), _NegLog10, _prec)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)

foreign import windowInnerSize :: ∀ e. Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: ∀ e.
                              String
                           -> Eff e Unit
                           -> Eff e Unit

foreign import keydownEvent :: ∀ e.
                                Element
                             -> (KeyboardEvent -> Eff e Unit)
                             -> Eff e Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ∀ e.
                              ({ width  :: Number
                               , height :: Number } -> Eff e Unit)
                           -> Eff e Unit

-- | The value returned by the function that initializes the genome browser;
-- | provides an interface to the running browser instance.
type BrowserInterface e a
  = { getView          :: Aff e CoordSysView
    , getBrowserCanvas :: Aff e BrowserCanvas
    , lastOverlaps     :: Aff e (Number -> Point -> a)
    , queueCommand     :: Variant UICmdR -> Aff e Unit
    , queueUpdateView  :: UpdateView -> Eff e Unit
    }

-- | Creates the browser using the provided initial data, returning
-- | a BrowserInterface for reading state & sending commands to it
initializeBrowser :: CoordSys _ _
                  -> (BrowserCanvas -> CoordSysView
                      -> { tracks :: { snps :: RenderedTrack (SNP ())
                                     , annotations :: RenderedTrack (Annotation ()) }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing })
                  -> CoordSysView
                  -> BrowserCanvas
                  -> Aff _ (BrowserInterface _ ({snps :: Array (SNP ())}))
initializeBrowser cSys mainBrowser initView bc = do

  renderFiberVar <- AVar.makeEmptyVar

  viewVar <- AVar.makeVar initView
  bcVar <- AVar.makeVar bc

  uiCmdVar <- AVar.makeEmptyVar
  lastOverlapsVar <- AVar.makeEmptyVar

  drawCachedBrowser <- browserCache mainBrowser

  let getView = AVar.readVar viewVar
      getBrowserCanvas = AVar.readVar bcVar
      queueCommand = flip AVar.putVar uiCmdVar
      lastOverlaps = AVar.readVar lastOverlapsVar

    -- hardcoded timeout for now
  queueUpdateView <- uiViewUpdate cSys (wrap 100.0) {view: viewVar, uiCmd: uiCmdVar}

  let mainLoop = do
        uiCmd <- AVar.takeVar uiCmdVar
        case_ # V.on _render (\_ -> pure unit)
              # V.on _docResize (\ {width} -> do
                      canvas <- AVar.takeVar bcVar
                      let {height} = canvas ^. _Dimensions
                      canvas' <- liftEff $ setBrowserCanvasSize {width, height} canvas
                      AVar.putVar canvas' bcVar
                      queueCommand $ inj _render unit
                      mainLoop)
              $ uiCmd
        -- case_ # V.on _render (\_ -> pure unit)
        --       # V.on _docResize (\ {width} -> do
        --               canvas <- AVar.takeVar bcVar
        --               {height} <- _.size <$> getDimensions canvas
        --               -- let {height} = dims.size
        --               _ <- liftEff $ setBrowserContainerSize {width, height} canvas
        --               AVar.putVar canvas bcVar
        --               queueCommand $ inj _render unit
        --               mainLoop)
        --       $ uiCmd

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

        csView <- getView
        canvas <- getBrowserCanvas
        toRender <- drawCachedBrowser canvas csView

        let currentScale = viewScale (canvas ^. _Track <<< _Dimensions) csView
            offset = scaleToScreen  currentScale (Pair.fst $ unwrap $ csView)

                          -- offset the click by the current canvas translation
        _ <- AVar.tryTakeVar lastOverlapsVar
        AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
                             in { snps: toRender.tracks.snps.overlaps n r' }) lastOverlapsVar

        -- fork a new renderFiber
        renderFiber <- forkAff
                       $ renderBrowser (wrap 2.0) canvas offset toRender
        AVar.putVar renderFiber renderFiberVar

        mainLoop

  _ <- forkAff mainLoop

  queueCommand $ inj _render unit

  pure { getView
       , getBrowserCanvas
       , lastOverlaps
       , queueCommand
       , queueUpdateView }

type BrowserInterface' e
  = { getView          :: Aff e CoordSysView
    , getBrowserCanvas :: Aff e BrowserContainer
    -- , lastOverlaps     :: Aff e (Number -> Point -> a)
    , queueCommand     :: Variant UICmdR -> Aff e Unit
    , queueUpdateView  :: UpdateView -> Eff e Unit
    }

initializeBrowser' :: ∀ r.
                      CoordSys _ _
                   -> { snps        :: Number -> CoordSysView -> Eff _ Unit
                      , annotations :: Number -> CoordSysView -> Eff _ Unit
                      , chrs        :: Number -> CoordSysView -> Eff _ Unit
                      , fixedUI     :: Eff _ Unit | r}
                  -> CoordSysView
                  -> BrowserContainer
                  -> Aff _ (BrowserInterface' _)
initializeBrowser' cSys renderFuns initView bc = do

  renderFiberVar <- AVar.makeEmptyVar

  viewVar <- AVar.makeVar initView
  bcVar <- AVar.makeVar bc

  uiCmdVar <- AVar.makeEmptyVar
  lastOverlapsVar <- AVar.makeEmptyVar

  let getView = AVar.readVar viewVar
      getBrowserCanvas = AVar.readVar bcVar
      queueCommand = flip AVar.putVar uiCmdVar
      lastOverlaps = AVar.readVar lastOverlapsVar

    -- hardcoded timeout for now
  queueUpdateView <- uiViewUpdate cSys (wrap 100.0) {view: viewVar, uiCmd: uiCmdVar}

  let mainLoop = do
        uiCmd <- AVar.takeVar uiCmdVar
        case_ # V.on _render (\_ -> pure unit)
              # V.on _docResize (\_ -> pure unit)
              -- # V.on _docResize (\ {width} -> do
              --         canvas <- AVar.takeVar bcVar
              --         {height} <- _.size <$> getDimensions canvas
              --         -- let {height} = dims.size
              --         _ <- liftEff $ setBrowserContainerSize {width, height} canvas
              --         AVar.putVar canvas bcVar
              --         queueCommand $ inj _render unit
              --         mainLoop)
              $ uiCmd

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

        csView <- getView
        canvas <- getBrowserCanvas
        -- toRender <- liftEff $ renderFuns.snps csView
        -- toRender <- drawCachedBrowser canvas csView

        currentDims <- getDimensions canvas

        let trackDims = _.padded $ browserSlots currentDims
            currentScale = viewScale trackDims.size csView
            offset = scaleToScreen  currentScale (Pair.fst $ unwrap $ csView)

                          -- offset the click by the current canvas translation
        -- _ <- AVar.tryTakeVar lastOverlapsVar
        -- AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
        --                      in unsafeCoerce $ unit) lastOverlapsVar
                             -- in { snps: toRender.tracks.snps.overlaps n r' }) lastOverlapsVar

        -- fork a new renderFiber
        renderFiber <- forkAff $ liftEff do
          log $ "rendering with offset: " <> show offset
          log <<< show =<< Map.keys <$> getLayers bc

          renderFuns.chrs        offset csView
          renderFuns.annotations offset csView
          renderFuns.snps        offset csView
          renderFuns.fixedUI

        AVar.putVar renderFiber renderFiberVar

        mainLoop

  _ <- forkAff mainLoop

  queueCommand $ inj _render unit

  pure { getView
       , getBrowserCanvas
       -- , lastOverlaps
       , queueCommand
       , queueUpdateView }

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

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
               -> CoordSysView
               -> CoordSysView
updateViewFold uv = over CoordSysView case uv of
  ZoomView   x -> (_ `scalePairBy`     x)
  ScrollView x -> (_ `translatePairBy` x)
  ModView f    -> f

queueCmd :: ∀ a. AVar a -> a -> Eff _ Unit
queueCmd av cmd = launchAff_ $ AVar.putVar cmd av

-- | Provided with the AVar containing the view state (which is updated atomically)
-- | and the UICmd AVar queue (which is only written to),
-- | return a function that queues view updates using the provided timeout.
uiViewUpdate :: ∀ r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view  :: AVar CoordSysView
                , uiCmd :: AVar (Variant UICmdR) | r }
             -> Aff _ (UpdateView -> Eff _ Unit)
uiViewUpdate cs timeout { view, uiCmd } = do
  viewCmd <- AVar.makeEmptyVar

  curCmdVar <- AVar.makeVar (ModView id)

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- AVar.takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

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

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"

            vr <- AVar.takeVar view
            let vr' = normView $ updateViewFold cmd' vr
            AVar.putVar vr' view

            AVar.putVar (inj _render unit) uiCmd
            AVar.takeVar curCmdVar *> AVar.putVar mempty curCmdVar

        loop' updater'

  _ <- forkAff $ loop' (pure unit)

  pure $ queueCmd viewCmd

btnUI :: { scrollMod :: Number, zoomMod :: Number }
      -> (UpdateView -> Eff _ Unit)
      -> Eff _ Unit
btnUI mods cb = do
  buttonEvent "scrollLeft"  $ cb $ ScrollView     (-mods.scrollMod)
  buttonEvent "scrollRight" $ cb $ ScrollView       mods.scrollMod
  buttonEvent "zoomOut"     $ cb $ ZoomView $ 1.0 + mods.zoomMod
  buttonEvent "zoomIn"      $ cb $ ZoomView $ 1.0 - mods.zoomMod

keyUI :: ∀ r.
         Element
      -> { scrollMod :: Number | r }
      -> (UpdateView -> Eff _ Unit)
      -> Eff _ Unit
keyUI el mods cb = keydownEvent el f
  where f ke = case DOM.key ke of
          "ArrowLeft"  -> cb $ ScrollView (-mods.scrollMod)
          "ArrowRight" -> cb $ ScrollView   mods.scrollMod
          _ -> pure unit

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

debugView :: BrowserInterface _ _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- s.getView
         liftEff do
           log $ "CoordSysView: " <> show (map BigInt.toString $ unwrap view)
           setWindow name $ (\(Pair l r) -> {l,r}) $ unwrap view

  let set lr = s.queueUpdateView
               $ ModView $ const (BigInt.fromNumber <$> Pair lr.l lr.r)

  pure {get, set}

browserCache
  :: ∀ a b.
     (BrowserCanvas
      -> CoordSysView
      -> { tracks :: { snps :: a
                     , annotations :: b }
         , relativeUI :: Drawing
         , fixedUI :: Drawing })
     -> Aff _ (BrowserCanvas
               -> CoordSysView
               -> Aff _ ({ tracks :: { snps :: a
                                     , annotations :: b }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing }))
browserCache f = do
  bcDim <- AVar.makeEmptyVar
  viewSize <- AVar.makeEmptyVar

  lastPartial <- AVar.makeEmptyVar
  lastFinal <- AVar.makeEmptyVar

  pure \bc csv -> do

    let newBCDim = bc ^. _Dimensions
    oldBCDim <- AVar.tryTakeVar bcDim
    AVar.putVar newBCDim bcDim

    oldPartial <- AVar.tryTakeVar lastPartial

    partial <- case oldBCDim, oldPartial of
      Just d, Just o -> do
        let changed = not $ d `eqRecord` newBCDim
        liftEff $ log $ "BrowserCanvas changed? " <> (show changed)
        -- remove the cached final output value on canvas resize,
        -- since we need to recalculate everything
        when changed (void $ AVar.tryTakeVar lastFinal)
        pure $ if d `eqRecord` newBCDim then o else f bc

      _, _ -> do
        liftEff $ log "Cache was empty! Recalculating all"
        _ <- AVar.tryTakeVar lastFinal
        pure $ f bc

    AVar.putVar partial lastPartial

    let newViewSize = pairSize $ unwrap csv
    oldViewSize <- AVar.tryTakeVar viewSize
    AVar.putVar newViewSize viewSize

    oldFinal <- AVar.tryTakeVar lastFinal

    let output = case oldViewSize, oldFinal of
          Just vs, Just o -> if newViewSize == vs then o else partial csv
          _, _ -> partial csv

    AVar.putVar output lastFinal
    pure output

printSNPInfo :: ∀ r. Array (SNP r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5
  log $ "showing " <> show m <> " out of " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) (log <<< unsafeCoerce)

wrapWith :: String -> String -> String
wrapWith tag x =
  "<"<> tag <>">" <> x <> "</"<> tag <>">"

snpHTML :: ∀ r.
           SNP r
        -> String
snpHTML {position, feature} = wrapWith "div" contents
  where contents = foldMap (wrapWith "p")
            [ "SNP: "    <> feature.name
            , "Chr: "    <> show feature.chrId
            , "Pos: "    <> show (Pair.fst position)
            , "-log10: " <> feature.score ^. _NegLog10 <<< _Newtype <<< _prec 4
            ]

peakHTML :: ∀ a.
            (a -> String)
         -> Peak _ _ a
         -> String
peakHTML disp peak =
  case Array.uncons peak.elements of
    Nothing               -> ""
    Just {head, tail: []} -> disp head
    Just {head, tail}     ->
      wrapWith "div" $ wrapWith "p"
        $ show (length tail + 1) <> " annotations"

-- | Given a function to transform the data in the annotation's "rest" field
-- | to text (or Nothing if the field should not be displayed), produce a
-- | function that generates HTML from annotations
annotationHTML :: (AnnotationField -> Maybe String)
                -> Annotation () -> String
annotationHTML disp {feature} = wrapWith "div" contents
  where url = fromMaybe "No URL"
              $ map (\a -> "URL: <a target='_blank' href='"
                           <> a <> "'>" <> a <> "") feature.url

        name = fromMaybe ("Annotated SNP: " <> feature.name)
                         (("Gene: " <> _) <$> feature.gene)

        showOther fv = fv.field <> ": " <> (unsafeCoerce fv.value)

        contents = foldMap (wrapWith "p")
          $ [ name
            , url
            ] <> (filterMap disp
                  $ Array.fromFoldable feature.rest)

-- | Shows all data in "rest" using the default showAnnotationField (which uses unsafeCoerce)
annotationHTMLAll :: Annotation () -> String
annotationHTMLAll =
  annotationHTML (pure <<< showAnnotationField)

annotationHTMLDefault :: Annotation () -> String
annotationHTMLDefault = annotationHTML \x -> pure case x of
  {field: "p_lrt", value} ->
     "p_lrt: " <> (unsafeCoerce value) ^. _NegLog10 <<< _Newtype <<< _prec 4
  fv -> showAnnotationField fv

-- | Example HTML generator that only shows the "anno" field
annotationHTMLAnnoOnly :: Annotation () -> String
annotationHTMLAnnoOnly = annotationHTML disp
  where disp fv
          | fv.field == "anno" = pure $ showAnnotationField fv
          | otherwise          = Nothing

foreign import initDebugDiv :: ∀ e. Number -> Eff e Unit
foreign import setDebugDivVisibility :: ∀ e. String -> Eff e Unit
foreign import setDebugDivPoint :: ∀ e. Point -> Eff e Unit

foreign import setElementContents :: ∀ e. Element -> String -> Eff e Unit

data InfoBoxF
  = IBoxShow
  | IBoxHide
  | IBoxSetY Int
  | IBoxSetX Int
  | IBoxSetContents String

derive instance genericInfoBoxF :: Generic InfoBoxF _

instance showInfoBoxF :: Show InfoBoxF where
  show = genericShow

updateInfoBox :: Element -> InfoBoxF -> Eff _ Unit
updateInfoBox el cmd =
  case cmd of
    IBoxShow ->
      setElementStyle el "visibility" "visible"
    IBoxHide ->
      setElementStyle el "visibility" "hidden"
    (IBoxSetX x)    ->
      setElementStyle el "left" $ show x <> "px"
    (IBoxSetY y)    ->
      setElementStyle el "top"  $ show y <> "px"
    (IBoxSetContents html) ->
      setElementContents el html

infoBoxId :: ElementId
infoBoxId = wrap "infoBox"

initInfoBox :: Eff _ (InfoBoxF -> Eff _ Unit)
initInfoBox = do
  doc <- map DOM.htmlDocumentToDocument
           $ DOM.document =<< DOM.window
  el <- DOM.createElement "div" doc

  DOM.setId infoBoxId el

  DOM.documentElement doc >>= case _ of
    Nothing -> throw "Couldn't find document body!"
    Just docBody -> void $ DOM.appendChild el docBody

  pure $ updateInfoBox el

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

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  cmdInfoBox <- liftEff $ initInfoBox

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

  trackData <-
    {genes:_, snps:_, annotations:_}
    <$> foldMap (getGenes       cSys) config.urls.genes
    <*> foldMap (getSNPs        cSys) config.urls.snps
    <*> foldMap (getAnnotations cSys) config.urls.annotations

  render <- liftEff
            $ addDemoLayers cSys config trackData bc

  browser <-
    initializeBrowser' cSys render (wrap $ Pair zero (cSys^._TotalSize)) bc

  -- zI

  browserClickHandler bc
    $ Padded 5.0 \pt -> do
        log $ "clicked Padded (" <> show pt.x <> ", " <> show pt.y <> ")"

  browserClickHandler bc
    $ CLeft \pt -> do
        log $ "clicked Left (" <> show pt.x <> ", " <> show pt.y <> ")"

  browserClickHandler bc
    $ CRight \pt -> do
        log $ "clicked Right (" <> show pt.x <> ", " <> show pt.y <> ")"

  liftEff do
    resizeEvent \d ->
      launchAff_ $ browser.queueCommand $ inj _docResize d

    let mods = { scrollMod: 0.05, zoomMod: 0.1 }

    btnUI mods browser.queueUpdateView

    -- keyUI (unsafeCoerce $ (unwrap bc).staticOverlay)
    --       mods browser.queueUpdateView

    dragScroll bc \ {x,y} ->
      -- only do anything when scrolling at least a pixel
      when (Math.abs x >= one) do
        trackDims <- _.padded <<< browserSlots <$> getDimensions bc
        browser.queueUpdateView
         $ ScrollView $ (-x) / trackDims.size.width

    let scrollZoomScale = 0.06
    wheelZoom bc \dY ->
       browser.queueUpdateView
         $ ZoomView $ 1.0 + scrollZoomScale * dY

    pure unit
{-
  liftEff do
    let overlayDebug :: _
        overlayDebug p = do
          setDebugDivVisibility "visible"
          setDebugDivPoint p

    let sigSnps = filterSig config.score trackData.snps
        annotAround pks snp =
          Array.find (\a -> a.covers `pairsOverlap` snp.position)
            =<< Map.lookup snp.feature.chrId pks

        glyphClick :: _
        glyphClick p = launchAff_ do
          v  <- browser.getView
          bc <- browser.getBrowserCanvas

          -- let segs = pixelSegments { segmentPadding: 12.0 } cSys bc v
          let segs = unsafeCoerce unit
              annoPeaks = annotationsForScale cSys sigSnps
                            trackData.annotations segs

          lastOverlaps' <- browser.lastOverlaps
          liftEff do
            let clicked = (lastOverlaps' clickRadius p).snps
            printSNPInfo clicked
            case Array.head clicked of
              Nothing -> cmdInfoBox IBoxHide
              Just g  -> do
                cmdInfoBox IBoxShow
                cmdInfoBox $ IBoxSetX $ Int.round p.x
                cmdInfoBox $ IBoxSetContents
                  $ snpHTML g
                  <> foldMap (peakHTML annotationHTMLDefault) (annotAround annoPeaks g)
-}

    {-
    ?browserOnClick bc
      { overlay: \_ -> pure unit
      -- { overlay: overlayDebug
      , track:   glyphClick }
    -}

    pure unit

  pure unit

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

type Conf =
  { browserHeight :: Number
  , trackPadding :: TrackPadding
  , score :: { min :: Number, max :: Number, sig :: Number }
  , urls :: DataURLs
  , snpsConfig        :: SNPConfig
  , annotationsConfig :: AnnotationsConfig
  , legend :: LegendConfig ()
  , vscale :: VScale ()
  }

foreign import setWindow :: ∀ e a. String -> a -> Eff e Unit

main :: Foreign -> Eff _ _
main rawConfig = do

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

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          -- bc <- browserCanvas dimensions c.trackPadding el
          bc <- browserContainer dimensions c.trackPadding el

          -- debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: ∀ 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 <- AVar.takeVar av
      AVar.putVar (sofar <> m) av
      delay (wrap 20.0)
      pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: ∀ a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- AVar.makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | 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
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes }
-}

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"   "171031299"
      , Tuple "Y"   "91744698"
      ]


Add reverse lookup for explicit imports

Add reverse lookup for explicit imports

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModuleName
  , getModulesForFile
  , getModulesForFileTemp
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , getModuleFromUnknownQualifier
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , addQualifiedImport
  , ImportResult(..)
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array (findLastIndex, filter, singleton, concatMap, (:))
import Data.Either (either, Either(..))
import Data.Foldable (all, notElem, elem)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Newtype (class Newtype)
import Data.StrMap as SM
import Data.String (Pattern(Pattern), split)
import Data.String.Regex (regex) as R
import Data.String.Regex.Flags (global, noFlags, multiline) as R
import Data.Tuple (Tuple(..))
import IdePurescript.Regex (replace', match', test')
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff as FS
import Node.Path (sep)
import PscIde as P
import PscIde.Command (ImportType(..))
import PscIde.Command as C

newtype Module = Module
  { moduleName :: String
  , importType :: C.ImportType
  , qualifier  :: Maybe String
  }

derive instance moduleNewtype :: Newtype Module _

instance moduleEq :: Eq Module where
  eq (Module m1) (Module m2) =
    m1.moduleName == m2.moduleName &&
    m1.qualifier == m2.qualifier &&
    m1.importType `eqImportType` m2.importType

eqImportType :: C.ImportType -> C.ImportType -> Boolean
eqImportType Implicit Implicit = true
eqImportType (Explicit idents) (Explicit idents') = idents == idents'
eqImportType (Hiding idents) (Hiding idents') = idents == idents'
eqImportType _ _ = false

getModuleName :: Module -> String
getModuleName (Module { moduleName }) = moduleName

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  , identToModule :: SM.StrMap Module
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case match' regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.multiline

getModulesForFile :: forall eff. Int -> Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile port file fullText = do
  C.ImportList { moduleName, imports } <- either (const default) id <$> P.listImports port file
  let modules = map mod imports
      main = maybe (getMainModule fullText) Just moduleName
      identToModule = SM.fromFoldable $ concatMap idents modules
      identifiers = SM.keys identToModule
  pure { main, modules, identifiers, identToModule }
  where
  default = C.ImportList { moduleName: Nothing, imports: [] }
  mod (C.Import imp) = Module imp
  idents m@(Module { importType: Explicit ids }) = flip Tuple m <$> ids
  idents _ = []

getModulesForFileTemp :: forall eff. Int -> Path -> String -> Aff (net :: P.NET, fs :: FS | eff) State
getModulesForFileTemp port file fullText = do
  tmpFile <- makeTempFile file fullText
  res <- getModulesForFile port tmpFile fullText
  _ <- attempt $ FS.unlink tmpFile
  pure res

mkImplicit :: String -> Module
mkImplicit m = Module { qualifier: Nothing, importType: Implicit, moduleName: m }

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules state@{modules, main} ident = getModules include state
  where
  include (Module { qualifier: Just _ }) = false
  include (Module { importType: Explicit idents }) = maybe false (\x -> x `elem` idents || ("(" <> x <> ")") `elem` idents) ident
  include (Module { importType: Implicit }) = true
  include (Module { importType: Hiding idents }) =  maybe true (_ `notElem` idents) ident

getAllActiveModules :: State -> Array String
getAllActiveModules = getModules (const true)

getModules :: (Module -> Boolean) -> State -> Array String
getModules include { modules, main } =
  ([ "Prim" ] <> _ ) $ map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> filter include modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Module { qualifier: Just q' }) = q == q'
  qual _ _ = false

getModuleFromUnknownQualifier :: String -> State -> Maybe Module
getModuleFromUnknownQualifier qual { identToModule } =
  SM.lookup qual identToModule <|> SM.lookup ("class " <> qual) identToModule

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [], identToModule: SM.empty }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split (Pattern "\n") text
      res = fromMaybe 0 $ findLastIndex (test' regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.TypeInfo) | FailedImport

makeTempFile :: forall eff. Path -> String -> Aff (fs :: FS | eff) Path
makeTempFile fileName text = do
  dir <- liftEff tmpDir
  let name = replace' (R.regex "[\\/\\\\:]" R.global) "-" fileName
      tmpFile = dir <> sep <> "ide-purescript-" <> name
  FS.writeTextFile UTF8 tmpFile text
  pure tmpFile

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  tmpFile <- makeTempFile fileName text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  _ <- attempt $ FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> Int -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state port fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport port tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && (mkImplicit moduleName `notElem` state.modules)

addExplicitImport :: forall eff. State -> Int -> String -> String -> Maybe String -> Maybe String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state port fileName text moduleName qualifier identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport port tmpFile (Just tmpFile) filters identifier qualifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && maybe true (\mn -> all (shouldAddMatch mn) state.modules) moduleName

    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Implicit })
      | moduleName' == mn = false
    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Hiding idents })
      | moduleName' == mn = identifier `elem` idents
    shouldAddMatch _ _ = true

addQualifiedImport :: forall eff. State -> Int -> String -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addQualifiedImport state port fileName text moduleName qualifier =
  if not isThisModule
    then { state, result: _ } <$> withTempFile fileName text addImport
    else pure { state, result: FailedImport }
  where
    addImport tmpFile = P.qualifiedImport port tmpFile (Just tmpFile) moduleName qualifier
    isThisModule = Just moduleName == state.main

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getModulesForFileTemp
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , addQualifiedImport
  , ImportResult(..)
  ) where

import Prelude
import Node.FS.Aff as FS
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array (findLastIndex, filter, singleton, concatMap, (:))
import Data.Either (either, Either(..))
import Data.Foldable (all, notElem, elem)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Newtype (class Newtype)
import Data.String (Pattern(Pattern), split)
import Data.String.Regex (regex) as R
import Data.String.Regex.Flags (global, noFlags, multiline) as R
import IdePurescript.Regex (replace', match', test')
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (sep)
import PscIde.Command (ImportType(..))

newtype Module = Module
  { moduleName :: String
  , importType :: C.ImportType
  , qualifier  :: Maybe String
  }

derive instance moduleNewtype :: Newtype Module _

instance moduleEq :: Eq Module where
  eq (Module m1) (Module m2) =
    m1.moduleName == m2.moduleName &&
    m1.qualifier == m2.qualifier &&
    m1.importType `eqImportType` m2.importType

eqImportType :: C.ImportType -> C.ImportType -> Boolean
eqImportType Implicit Implicit = true
eqImportType (Explicit idents) (Explicit idents') = idents == idents'
eqImportType (Hiding idents) (Hiding idents') = idents == idents'
eqImportType _ _ = false

getModuleName :: Module -> String
getModuleName (Module { moduleName }) = moduleName

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case match' regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.multiline

getModulesForFile :: forall eff. Int -> Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile port file fullText = do
  C.ImportList { moduleName, imports } <- either (const default) id <$> P.listImports port file
  let modules = map mod imports
      main = maybe (getMainModule fullText) Just moduleName
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  default = C.ImportList { moduleName: Nothing, imports: [] }
  mod (C.Import imp) = Module imp
  idents (Module { importType: Explicit ids }) = ids
  idents _ = []

getModulesForFileTemp :: forall eff. Int -> Path -> String -> Aff (net :: P.NET, fs :: FS | eff) State
getModulesForFileTemp port file fullText = do
  tmpFile <- makeTempFile file fullText
  res <- getModulesForFile port tmpFile fullText
  _ <- attempt $ FS.unlink tmpFile
  pure res

mkImplicit :: String -> Module
mkImplicit m = Module { qualifier: Nothing, importType: Implicit, moduleName: m }

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules state@{modules, main} ident = getModules include state
  where
  include (Module { qualifier: Just _ }) = false
  include (Module { importType: Explicit idents }) = maybe false (\x -> x `elem` idents || ("(" <> x <> ")") `elem` idents) ident
  include (Module { importType: Implicit }) = true
  include (Module { importType: Hiding idents }) =  maybe true (_ `notElem` idents) ident

getAllActiveModules :: State -> Array String
getAllActiveModules = getModules (const true)

getModules :: (Module -> Boolean) -> State -> Array String
getModules include { modules, main } =
  ([ "Prim" ] <> _ ) $ map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> filter include modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Module { qualifier: Just q' }) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split (Pattern "\n") text
      res = fromMaybe 0 $ findLastIndex (test' regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.TypeInfo) | FailedImport

makeTempFile :: forall eff. Path -> String -> Aff (fs :: FS | eff) Path
makeTempFile fileName text = do
  dir <- liftEff tmpDir
  let name = replace' (R.regex "[\\/\\\\:]" R.global) "-" fileName
      tmpFile = dir <> sep <> "ide-purescript-" <> name
  FS.writeTextFile UTF8 tmpFile text
  pure tmpFile

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  tmpFile <- makeTempFile fileName text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  _ <- attempt $ FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> Int -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state port fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport port tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && (mkImplicit moduleName `notElem` state.modules)

addExplicitImport :: forall eff. State -> Int -> String -> String -> Maybe String -> Maybe String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state port fileName text moduleName qualifier identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport port tmpFile (Just tmpFile) filters identifier qualifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && maybe true (\mn -> all (shouldAddMatch mn) state.modules) moduleName

    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Implicit })
      | moduleName' == mn = false
    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Hiding idents })
      | moduleName' == mn = identifier `elem` idents
    shouldAddMatch _ _ = true

addQualifiedImport :: forall eff. State -> Int -> String -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addQualifiedImport state port fileName text moduleName qualifier =
  if not isThisModule
    then { state, result: _ } <$> withTempFile fileName text addImport
    else pure { state, result: FailedImport }
  where
    addImport tmpFile = P.qualifiedImport port tmpFile (Just tmpFile) moduleName qualifier
    isThisModule = Just moduleName == state.main


allows State to be generated from a series of actions

module Openspace.Engine where

import Openspace.Types
import Data.Maybe
import Data.Foldable
import qualified Data.Map as M
import Data.Tuple
import Data.Array

evalAction :: Action -> AppState -> AppState
evalAction (AddTopic t) as      = addTopic t as
evalAction (DeleteTopic t) as   = deleteTopic t as
evalAction (AddRoom r) as       = addRoom r as
evalAction (DeleteRoom r) as    = deleteRoom r as
evalAction (AddBlock b) as      = addBlock b as
evalAction (DeleteBlock b) as   = deleteBlock b as
evalAction (AssignTopic s t) as = addTimeslot s t as
evalAction (UnassignTopic t) as = let topicslotFilter = filter (\(Tuple _ t') -> t' /= t)
                                  in as {timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
evalAction (ShowError e) as     = as
evalAction NOP as               = as

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                     in as { timeslots = M.insert s t $ M.fromList $ topicslotFilter (M.toList as.timeslots) }

deleteTimeslot :: Slot -> AppState -> AppState
deleteTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

deleteTopic :: Topic -> AppState -> AppState
deleteTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

addRoom :: Room -> AppState -> AppState
addRoom r as = as { rooms = r : as.rooms }

deleteRoom :: Room -> AppState -> AppState
deleteRoom r as = as { rooms = filter (\r' -> r' /= r ) as.rooms
                     , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.room /= r)

addBlock :: Block -> AppState -> AppState
addBlock b as = as { blocks = b : as.blocks }

deleteBlock :: Block -> AppState -> AppState
deleteBlock b as = as { blocks = filter (\b' -> b' /= b ) as.blocks
                      , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.block /= b)

generateState :: [Action] -> AppState
generateState as = foldl (flip evalAction) emptyState as

module Openspace.Engine where

import Openspace.Types
import Data.Maybe
import qualified Data.Map as M
import Data.Tuple
import Data.Array

evalAction :: Action -> AppState -> AppState
evalAction (AddTopic t) as      = addTopic t as
evalAction (DeleteTopic t) as   = deleteTopic t as
evalAction (AddRoom r) as       = addRoom r as
evalAction (DeleteRoom r) as    = deleteRoom r as
evalAction (AddBlock b) as      = addBlock b as
evalAction (DeleteBlock b) as   = deleteBlock b as
evalAction (AssignTopic s t) as = addTimeslot s t as
evalAction (UnassignTopic t) as = let topicslotFilter = filter (\(Tuple _ t') -> t' /= t)
                                  in as {timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
evalAction (ShowError e) as     = as
evalAction NOP as               = as

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                     in as { timeslots = M.insert s t $ M.fromList $ topicslotFilter (M.toList as.timeslots) }

deleteTimeslot :: Slot -> AppState -> AppState
deleteTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

deleteTopic :: Topic -> AppState -> AppState
deleteTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

addRoom :: Room -> AppState -> AppState
addRoom r as = as { rooms = r : as.rooms }

deleteRoom :: Room -> AppState -> AppState
deleteRoom r as = as { rooms = filter (\r' -> r' /= r ) as.rooms
                     , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.room /= r)

addBlock :: Block -> AppState -> AppState
addBlock b as = as { blocks = b : as.blocks }

deleteBlock :: Block -> AppState -> AppState
deleteBlock b as = as { blocks = filter (\b' -> b' /= b ) as.blocks
                      , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.block /= b)


makeAff -> liftEff

makeAff -> liftEff

module Routing.Hash.Aff where

import DOM
import Control.Monad.Aff
import Control.Monad.Eff.Class
import qualified Routing.Hash as R

modifyHash :: forall e. (String -> String) -> Aff (dom :: DOM|e) Unit
modifyHash func = liftEff $ R.modifyHash func

setHash :: forall e. String -> Aff (dom :: DOM|e) Unit
setHash hash = liftEff $ R.setHash hash

module Routing.Hash.Aff where

import DOM
import Control.Monad.Aff
import qualified Routing.Hash as R

modifyHash :: forall e. (String -> String) -> Aff (dom :: DOM|e) Unit
modifyHash func = makeAff \_ k -> do
  R.modifyHash func
  k unit

setHash :: forall e. String -> Aff (dom :: DOM|e) Unit
setHash hash = makeAff \_ k -> do
  R.setHash hash
  k unit


Refactor

Refactor

module Main where

import Prelude

import Notebook.Types (Notebook)
import App.Types
import App.State as App
import App.View as App
import BackendConnection.Types as BackendConnection
import BackendConnection.State as BackendConnection
import Cells.Types as Cells
import Cells.State as Cells
import Console.Types as Console
import Console.State as Console
import Columns.Types as Columns
import Columns.State as Columns

import WebSocket (URL(..))
import DOM
import Signal
import Control.Monad.Eff (Eff)
import Global.Effects (GlobalEffects)
import Pux (CoreEffects, renderToDOM, fromSimple, start)
import Signal.Channel (subscribe, channel, CHANNEL, Channel)

main :: Eff (CoreEffects GlobalEffects) Unit
main = do
    cellsChannel <- channel Cells.NoOp
    backendConnectionChannel <- channel (BackendConnection.NoOp :: BackendConnection.Action Notebook)
    consoleChannel <- channel Console.NoOp
    backendConnectionState <- BackendConnection.initialState backendConnectionChannel (URL "ws://127.0.0.1:3000")

    let cellsState             = Cells.initialState cellsChannel
        consoleState           = Console.initialState consoleChannel
        inputSignals =
            [ consoleChannel `liftAction` buildAndSend
            , backendConnectionChannel `liftAction` updateStateAfterReceiving
            , cellsChannel `liftAction` CellsAction
            ]
    app <- start
        { initialState : App.initialState cellsState {} backendConnectionState consoleState
        , update : App.update
        , view : App.view
        , inputs : inputSignals
        }
    renderToDOM "#app" app.html

buildAndSend :: Console.Action -> Action
buildAndSend Console.PackAndSendToBackend = BuildAndSend
buildAndSend _ = NoOp

updateStateAfterReceiving :: BackendConnection.Action Notebook -> Action
updateStateAfterReceiving (BackendConnection.Receive n) = UpdateState n
updateStateAfterReceiving _ = NoOp

liftAction :: forall subaction action . Channel subaction -> (subaction -> action) -> Signal action
liftAction chan act = map act $ subscribe chan

module Main where

import Prelude

import Notebook.Types (Notebook)
import App.Types
import App.State as App
import App.View as App
import BackendConnection.Types as BackendConnection
import BackendConnection.State as BackendConnection
import Cells.Types as Cells
import Cells.State as Cells
import Console.Types as Console
import Console.State as Console
import Columns.Types as Columns
import Columns.State as Columns

import WebSocket (URL(..))
import DOM
import Signal
import Control.Monad.Eff (Eff)
import Global.Effects (GlobalEffects)
import Pux (CoreEffects, renderToDOM, fromSimple, start)
import Signal.Channel (subscribe, channel, CHANNEL, Channel)

main :: Eff (CoreEffects GlobalEffects) Unit
main = do
    cellsChannel <- channel Cells.NoOp
    backendConnectionChannel <- channel (BackendConnection.NoOp :: BackendConnection.Action Notebook)
    consoleChannel <- channel Console.NoOp
    backendConnectionState <- BackendConnection.initialState backendConnectionChannel (URL "ws://127.0.0.1:3000")

    let sig = consoleChannel `mapSub` f
    let sig2 = backendConnectionChannel `mapSub` g
    let sig3 = cellsChannel `mapSub` CellsAction

    let cellsState             = Cells.initialState cellsChannel
        consoleState           = Console.initialState consoleChannel
        inputSignals =
            [ sig
            , sig2
            , sig3
            ]
    app <- start
        { initialState : App.initialState cellsState {} backendConnectionState consoleState
        , update : App.update
        , view : App.view
        , inputs : inputSignals
        }
    renderToDOM "#app" app.html

f :: Console.Action -> Action
f Console.PackAndSendToBackend = BuildAndSend
f _ = NoOp

g :: BackendConnection.Action Notebook -> Action
g (BackendConnection.Receive n) = UpdateState n
g _ = NoOp

mapSub :: forall subaction action . Channel subaction -> (subaction -> action) -> Signal action
mapSub chan act = map act $ subscribe chan


[CSM-233] Finish client-api backend endpoints for tls

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error, Error, throwException)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, _address, _ccoin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPaperVendWalletRedeem)
import Data.Array (last)
import Data.Argonaut (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap, lmap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(GET, POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple (..))
import Data.StrMap (fromFoldable)
import Daedalus.TLS (TLSOptions)
import Node.HTTP.Client (method, path, request, statusCode, statusMessage, Response, responseAsStream, headers, RequestHeaders (..), Request, requestAsStream)
import Data.Options ((:=))
import Node.Encoding (Encoding (UTF8))
import Node.Stream (onDataString, writeString, end)
import Node.HTTP (HTTP)

-- HELPERS

type URLPath = Array String
type URL = String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path <> ifEmptyEnd
  where
    -- Workaround for passing empty passphrases as last capture in URL
    ifEmptyEnd = if last path == Just "" then [""] else []

data ApiError
    = HTTPStatusError Response
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show (statusCode res) <> " msg: " <> statusMessage res
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => String -> Either Error a
decodeResult = either (Left <<< mkJSONError) (lmap mkServerError) <<< decodeJson <=< lmap error <<< jsonParser
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a. (Generic a) => (Request -> Eff (http :: HTTP, err :: EXCEPTION | eff) Unit) -> TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
makeRequest withReq tls urlPath = do
    -- FIXME: exceptin shouldn't happen here?
    res <- makeAff $ const $ withReq <=< request (tls <> path := backendApi urlPath)
    when (isHttpError res) $
        throwError <<< error <<< show $ HTTPStatusError res
    rawData <- makeAff $ const $ onDataString (responseAsStream res) UTF8
    either throwError pure $ decodeResult rawData
  where
    isHttpError res = statusCode res >= 400

plainRequest :: forall eff a r. (Generic a) => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
plainRequest = makeRequest $ void <<< pure

bodyRequest :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
bodyRequest tls urlPath body = makeRequest flushBody (tls <> headers := reqHeaders) urlPath
  where
    flushBody req = do
        let writeStream = requestAsStream req
        writeString writeStream UTF8 (show $ encodeJson body) $ pure unit
        end writeStream $ pure unit
    -- TODO: use Data.MediaType.Common here
    reqHeaders = RequestHeaders $ fromFoldable [Tuple "Content-Type" "application/json"]

getR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
getR tls = plainRequest $ tls <> method := (show GET)

postR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
postR tls = plainRequest $ tls <> method := (show POST)

postRBody :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
postRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show POST)

putRBody :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
putRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show PUT)

deleteR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
deleteR tls = plainRequest $ tls <> method := (show DELETE)

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) Unit
testReset tls = postR tls ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) (Array CWallet)
getWallets tls = getR tls ["wallets"]

getWallet :: forall eff. TLSOptions -> CAddress -> Aff (http :: HTTP, err :: EXCEPTION | eff) CWallet
getWallet tls addr = getR tls ["wallets", _address addr]

updateWallet :: forall eff. TLSOptions -> CAddress -> CWalletMeta -> Aff (http :: HTTP, err :: EXCEPTION | eff) CWallet
updateWallet tls addr = putRBody tls ["wallets", _address addr]

newWallet :: forall eff. TLSOptions -> CPassPhrase -> CWalletInit -> Aff (http :: HTTP, err :: EXCEPTION | eff) CWallet
newWallet tls pass = postRBody tls ["wallets", _passPhrase pass]

deleteWallet :: forall eff. TLSOptions -> CAddress -> Aff (http :: HTTP, err :: EXCEPTION | eff) Unit
deleteWallet tls addr = deleteR tls ["wallets", _address addr]

importKey :: forall eff. TLSOptions -> String -> Aff (http :: HTTP, err :: EXCEPTION | eff) CWallet
importKey tls = postRBody tls ["wallets", "keys"]

restoreWallet :: forall eff. TLSOptions -> CPassPhrase -> CWalletInit -> Aff (http :: HTTP, err :: EXCEPTION | eff) CWallet
restoreWallet tls pass = postRBody tls ["wallets", "restore", _passPhrase pass]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. TLSOptions -> CCurrency -> String -> Aff (http :: HTTP, err :: EXCEPTION | eff) Boolean
isValidAddress tls cCurrency addr = getR tls ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) CProfile
getProfile tls = getR tls ["profile"]

updateProfile :: forall eff. TLSOptions -> CProfile -> Aff (http :: HTTP, err :: EXCEPTION | eff) CProfile
updateProfile tls = postRBody tls ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. TLSOptions -> CPassPhrase -> CAddress -> CAddress -> CCoin -> Aff (http :: HTTP, err :: EXCEPTION | eff) CTx
send tls pass addrFrom addrTo amount = postR tls ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount]

sendExtended :: forall eff. TLSOptions -> CPassPhrase -> CAddress -> CAddress -> CCoin -> CCurrency -> String -> String -> Aff (http :: HTTP, err :: EXCEPTION | eff) CTx
sendExtended tls pass addrFrom addrTo amount curr title desc = postR tls ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount, showCCurrency curr, title, desc]

updateTransaction :: forall eff. TLSOptions -> CAddress -> CTxId -> CTxMeta -> Aff (http :: HTTP, err :: EXCEPTION | eff) Unit
updateTransaction tls addr ctxId = postRBody tls ["txs", "payments", _address addr, _ctxIdValue ctxId]

getHistory :: forall eff. TLSOptions -> CAddress -> Int -> Int -> Aff (http :: HTTP, err :: EXCEPTION | eff) (Tuple (Array CTx) Int)
getHistory tls addr skip limit = getR tls ["txs", "histories", _address addr <> "?skip=" <> show skip <> "&limit=" <> show limit]

searchHistory :: forall eff. TLSOptions -> CAddress -> String -> Int -> Int -> Aff (http :: HTTP, err :: EXCEPTION | eff) (Tuple (Array CTx) Int)
searchHistory tls addr search skip limit = getR tls ["txs", "histories", _address addr, search <> "?skip=" <> show skip <> "&limit=" <> show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) CUpdateInfo
nextUpdate tls = getR tls ["update"]

applyUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) Unit
applyUpdate tls = postR tls ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemAda :: forall eff. TLSOptions -> CWalletRedeem -> Aff (http :: HTTP, err :: EXCEPTION | eff) CTx
redeemAda tls = postRBody tls ["redemptions", "ada"]

redeemAdaPaperVend :: forall eff. TLSOptions -> CPaperVendWalletRedeem -> Aff (http :: HTTP, err :: EXCEPTION | eff) CTx
redeemAdaPaperVend tls = postRBody tls ["papervend", "redemptions", "ada"]
--------------------------------------------------------------------------------
-- REPORTING ---------------------------------------------------------------------
reportInit :: forall eff. TLSOptions -> CInitialized -> Aff (http :: HTTP, err :: EXCEPTION | eff) Unit
reportInit tls = postRBody tls ["reporting", "initialized"]
--------------------------------------------------------------------------------
-- SETTINGS ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) Int
blockchainSlotDuration tls = getR tls ["settings", "slots", "duration"]

systemVersion :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) SoftwareVersion
systemVersion tls = getR tls ["settings", "version"]

syncProgress :: forall eff. TLSOptions -> Aff (http :: HTTP, err :: EXCEPTION | eff) SyncProgress
syncProgress tls = getR tls ["settings", "sync", "progress"]
--------------------------------------------------------------------------------

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error, Error, throwException)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, _address, _ccoin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPaperVendWalletRedeem)
import Data.Array (last)
import Data.Argonaut (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap, lmap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(GET, POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple (..))
import Data.StrMap (fromFoldable)
import Daedalus.TLS (TLSOptions)
import Node.HTTP.Client (method, path, request, statusCode, statusMessage, Response, responseAsStream, headers, RequestHeaders (..), Request, requestAsStream)
import Data.Options ((:=))
import Node.Encoding (Encoding (UTF8))
import Node.Stream (onDataString, writeString, end)
import Node.HTTP (HTTP)

-- HELPERS

type URLPath = Array String
type URL = String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path <> ifEmptyEnd
  where
    -- Workaround for passing empty passphrases as last capture in URL
    ifEmptyEnd = if last path == Just "" then [""] else []

data ApiError
    = HTTPStatusError Response
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show (statusCode res) <> " msg: " <> statusMessage res
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => String -> Either Error a
decodeResult = either (Left <<< mkJSONError) (lmap mkServerError) <<< decodeJson <=< lmap error <<< jsonParser
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a. (Generic a) => (Request -> Eff (http :: HTTP, err :: EXCEPTION | eff) Unit) -> TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
makeRequest withReq tls urlPath = do
    -- FIXME: exceptin shouldn't happen here?
    res <- makeAff $ const $ withReq <=< request (tls <> path := backendApi urlPath)
    when (isHttpError res) $
        throwError <<< error <<< show $ HTTPStatusError res
    rawData <- makeAff $ const $ onDataString (responseAsStream res) UTF8
    either throwError pure $ decodeResult rawData
  where
    isHttpError res = statusCode res >= 400

plainRequest :: forall eff a r. (Generic a) => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
plainRequest = makeRequest $ void <<< pure

bodyRequest :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
bodyRequest tls urlPath body = makeRequest flushBody (tls <> headers := reqHeaders) urlPath
  where
    flushBody req = do
        let writeStream = requestAsStream req
        writeString writeStream UTF8 (show $ encodeJson body) $ pure unit
        end writeStream $ pure unit
    -- TODO: use Data.MediaType.Common here
    reqHeaders = RequestHeaders $ fromFoldable [Tuple "Content-Type" "application/json"]

getR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
getR tls = plainRequest $ tls <> method := (show GET)

postR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
postR tls = plainRequest $ tls <> method := (show POST)

postRBody :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
postRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show POST)

putRBody :: forall eff a b. (Generic a, Generic b) => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
putRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show PUT)

deleteR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, err :: EXCEPTION | eff) a
deleteR tls = plainRequest $ tls <> method := (show DELETE)

-- -- REQUESTS
-- --------------------------------------------------------------------------------
-- -- TEST ------------------------------------------------------------------------
-- testReset :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) Unit
-- testReset _ = postR ["test", "reset"]
-- --------------------------------------------------------------------------------
-- -- WALLETS ---------------------------------------------------------------------
-- getWallets :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) (Array CWallet)
-- getWallets _ = getR ["wallets"]
--
-- getWallet :: forall eff. TLSOptions -> CAddress -> Aff (ajax :: AJAX | eff) CWallet
-- getWallet _ addr = getR ["wallets", _address addr]
--
-- updateWallet :: forall eff. TLSOptions -> CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
-- updateWallet _ addr = putRBody ["wallets", _address addr]
--
-- newWallet :: forall eff. TLSOptions -> CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
-- newWallet _ pass = postRBody ["wallets", _passPhrase pass]
--
-- deleteWallet :: forall eff. TLSOptions -> CAddress -> Aff (ajax :: AJAX | eff) Unit
-- deleteWallet _ addr = deleteR ["wallets", _address addr]
--
-- importKey :: forall eff. TLSOptions -> String -> Aff (ajax :: AJAX | eff) CWallet
-- importKey _ = postRBody ["wallets", "keys"]
--
-- restoreWallet :: forall eff. TLSOptions -> CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
-- restoreWallet _ pass = postRBody ["wallets", "restore", _passPhrase pass]
-- --------------------------------------------------------------------------------
-- -- ADDRESSSES ------------------------------------------------------------------
-- isValidAddress :: forall eff. TLSOptions -> CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
-- isValidAddress _ cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
-- --------------------------------------------------------------------------------
-- -- PROFILES --------------------------------------------------------------------
-- getProfile :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) CProfile
-- getProfile _ = getR ["profile"]
--
-- updateProfile :: forall eff. TLSOptions -> CProfile -> Aff (ajax :: AJAX | eff) CProfile
-- updateProfile _ = postRBody ["profile"]
-- --------------------------------------------------------------------------------
-- -- TRANSACTIONS ----------------------------------------------------------------
-- send :: forall eff. TLSOptions -> CPassPhrase -> CAddress -> CAddress -> CCoin -> Aff (ajax :: AJAX | eff) CTx
-- send _ pass addrFrom addrTo amount = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount]
--
-- sendExtended :: forall eff. TLSOptions -> CPassPhrase -> CAddress -> CAddress -> CCoin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
-- sendExtended _ pass addrFrom addrTo amount curr title desc = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount, showCCurrency curr, title, desc]
--
-- updateTransaction :: forall eff. TLSOptions -> CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
-- updateTransaction _ addr ctxId = postRBody ["txs", "payments", _address addr, _ctxIdValue ctxId]
--
-- getHistory :: forall eff. TLSOptions -> CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
-- getHistory _ addr skip limit = getR ["txs", "histories", _address addr <> "?skip=" <> show skip <> "&limit=" <> show limit]
--
-- searchHistory :: forall eff. TLSOptions -> CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
-- searchHistory _ addr search skip limit = getR ["txs", "histories", _address addr, search <> "?skip=" <> show skip <> "&limit=" <> show limit]
-- --------------------------------------------------------------------------------
-- -- UPDATES ---------------------------------------------------------------------
-- nextUpdate :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) CUpdateInfo
-- nextUpdate _ = getR ["update"]
--
-- applyUpdate :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) Unit
-- applyUpdate _ = postR ["update"]
-- --------------------------------------------------------------------------------
-- -- REDEMPTIONS -----------------------------------------------------------------
-- redeemAda :: forall eff. TLSOptions -> CWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
-- redeemAda _ = postRBody ["redemptions", "ada"]
--
-- redeemAdaPaperVend :: forall eff. TLSOptions -> CPaperVendWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
-- redeemAdaPaperVend _ = postRBody ["papervend", "redemptions", "ada"]
-- --------------------------------------------------------------------------------
-- -- REPORTING ---------------------------------------------------------------------
-- reportInit :: forall eff. TLSOptions -> CInitialized -> Aff (ajax :: AJAX | eff) Unit
-- reportInit _ = postRBody ["reporting", "initialized"]
-- --------------------------------------------------------------------------------
-- -- SETTINGS ---------------------------------------------------------------------
-- blockchainSlotDuration :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) Int
-- blockchainSlotDuration _ = getR ["settings", "slots", "duration"]
--
-- systemVersion :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) SoftwareVersion
-- systemVersion _ = getR ["settings", "version"]
--
-- syncProgress :: forall eff. TLSOptions -> Aff (ajax :: AJAX | eff) SyncProgress
-- syncProgress _ = getR ["settings", "sync", "progress"]
-- --------------------------------------------------------------------------------