moved most of UI to BrowserContainer

moved most of UI to BrowserContainer

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.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 (Peak, RenderedTrack, pixelSegments)
import Genetics.Browser.Canvas (BrowserCanvas, BrowserContainer(..), TrackPadding, _Dimensions, _Track, browserCanvas, browserContainer, browserOnClick, debugBrowserCanvas, dragScroll, dragScroll', getDimensions, renderBrowser, renderBrowser', setBrowserCanvasSize, setBrowserContainerSize, setElementStyle, wheelZoom, wheelZoom')
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(CoordSysView), _TotalSize, coordSys, normalizeView, pairSize, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, annotationsForScale, demoBrowser, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
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     :: 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 _ _
                  -> (BrowserContainer -> CoordSysView
                      -> { tracks :: { snps :: RenderedTrack (SNP ())
                                     , annotations :: RenderedTrack (Annotation ()) }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing })
                  -> CoordSysView
                  -> BrowserContainer
                  -> 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
                      {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

        currentDims <- getDimensions canvas
        let currentScale = viewScale currentDims.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 { snps: toRender.tracks.snps.overlaps n r' }) lastOverlapsVar

        let toRender' :: _
            toRender' = unsafeCoerce unit

        -- fork a new renderFiber
        renderFiber <- forkAff
                       -- $ renderBrowser (wrap 2.0) canvas offset toRender
                       $ renderBrowser' canvas (wrap 2.0) offset toRender'
        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.
     (BrowserContainer
      -> CoordSysView
      -> { tracks :: { snps :: a
                     , annotations :: b }
         , relativeUI :: Drawing
         , fixedUI :: Drawing })
     -> Aff _ (BrowserContainer
               -> 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

    newBCDim <- _.size <$> getDimensions bc
    -- 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

  let mainBrowser = unsafeCoerce $ demoBrowser cSys config trackData

  browser <-
    initializeBrowser cSys mainBrowser (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} ->
    --    when (Math.abs x >= one) $ launchAff_ do
    --      trackDims <- Lens.view (_Track <<< _Dimensions)
    --                   <$> browser.getBrowserCanvas

    --      liftEff $ browser.queueUpdateView
    --              $ ScrollView $ (-x) / trackDims.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
            }

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 <- 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.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 (Peak, RenderedTrack, pixelSegments)
import Genetics.Browser.Canvas (BrowserCanvas, TrackPadding, _Dimensions, _Track, browserCanvas, browserOnClick, debugBrowserCanvas, dragScroll, renderBrowser, setBrowserCanvasSize, setElementStyle, wheelZoom)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView(CoordSysView), _TotalSize, coordSys, normalizeView, pairSize, pairsOverlap, scalePairBy, scaleToScreen, translatePairBy, viewScale)
import Genetics.Browser.Demo (Annotation, AnnotationField, SNP, annotationsForScale, demoBrowser, filterSig, getAnnotations, getGenes, getSNPs, showAnnotationField)
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

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

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

  let mainBrowser = demoBrowser cSys config trackData

  browser <-
    initializeBrowser cSys mainBrowser (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} ->
       when (Math.abs x >= one) $ launchAff_ do
         trackDims <- Lens.view (_Track <<< _Dimensions)
                      <$> browser.getBrowserCanvas

         liftEff $ browser.queueUpdateView
                 $ ScrollView $ (-x) / trackDims.width

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

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

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
            }

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

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


remove unused references

remove unused references

module Request.CreateToken (createToken) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.CreateTokenResponse (CreateTokenResponse)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), body, headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)

createToken :: forall eff
               . String
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) CreateTokenResponse
createToken email password = do
  text <- fetch options
  let f = readJSON text :: F CreateTokenResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  ]
    body = "{" <>
          "\"view_type\":\"admin\"" <> "," <>
          "\"email\":\"" <> email <> "\"" <> "," <>
          "\"password\":\"" <> password <> "\"" <>
          "}"
    options = FetchOptions.method := FetchOptions.POST
              <> FetchOptions.url := "https://api.rallyapp.jp/tokens"
              <> FetchOptions.headers := headers
              <> FetchOptions.body := body

module Request.CreateToken (createToken) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (EXCEPTION, error, throw)
import Control.Monad.Except (runExcept)
import Data.CreateTokenResponse (CreateTokenResponse)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), body, headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)

createToken :: forall eff
               . String
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) CreateTokenResponse
createToken email password = do
  text <- fetch options
  let f = readJSON text :: F CreateTokenResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  ]
    body = "{" <>
          "\"view_type\":\"admin\"" <> "," <>
          "\"email\":\"" <> email <> "\"" <> "," <>
          "\"password\":\"" <> password <> "\"" <>
          "}"
    options = FetchOptions.method := FetchOptions.POST
              <> FetchOptions.url := "https://api.rallyapp.jp/tokens"
              <> FetchOptions.headers := headers
              <> FetchOptions.body := body


Use Timestamp rather than DateTime name in UI

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.FormBuilder.Item.FieldType
  ( FieldType(..)
  , allFieldTypes
  , _FieldTypeDisplayName
  , fieldTypeToInputType
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Argonaut.Decode as JD
import Data.Argonaut.Encode as JE
import Data.Lens as Lens
import Data.List as L

import Halogen.HTML.Properties as HP

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data FieldType
  = StringFieldType
  | BooleanFieldType
  | NumericFieldType
  | DateTimeFieldType
  | DateFieldType
  | TimeFieldType
  | IntervalFieldType
  | ObjectIdFieldType
  | ArrayFieldType
  | ObjectFieldType
  | SqlExprFieldType
  | SqlIdentifierFieldType

derive instance genericFieldType ∷ Generic FieldType
derive instance eqFieldType ∷ Eq FieldType
derive instance ordFieldType ∷ Ord FieldType

instance arbitraryFieldType ∷ SC.Arbitrary FieldType where
  arbitrary =
    Gen.elements
      StringFieldType
      (L.fromFoldable allFieldTypes)

allFieldTypes ∷ Array FieldType
allFieldTypes =
  [ StringFieldType
  , DateTimeFieldType
  , DateFieldType
  , TimeFieldType
  , IntervalFieldType
  , BooleanFieldType
  , NumericFieldType
  , ObjectIdFieldType
  , ArrayFieldType
  , ObjectFieldType
  , SqlExprFieldType
  , SqlIdentifierFieldType
  ]

_FieldTypeDisplayName ∷ Lens.Prism' String FieldType
_FieldTypeDisplayName = Lens.prism inj proj
  where
    inj StringFieldType = "Text"
    inj DateTimeFieldType = "Timestamp"
    inj DateFieldType = "Date"
    inj TimeFieldType = "Time"
    inj IntervalFieldType = "Interval"
    inj BooleanFieldType = "Boolean"
    inj NumericFieldType = "Numeric"
    inj ObjectIdFieldType = "Object ID"
    inj ArrayFieldType = "Array"
    inj ObjectFieldType = "Object"
    inj SqlExprFieldType = "SQL² Expression"
    inj SqlIdentifierFieldType = "SQL² Identifier"

    proj "Text" = Right StringFieldType
    proj "Timestamp" = Right DateTimeFieldType
    proj "Date" = Right DateFieldType
    proj "Time" = Right TimeFieldType
    proj "Interval" = Right IntervalFieldType
    proj "Boolean" = Right BooleanFieldType
    proj "Numeric" = Right NumericFieldType
    proj "Object ID" = Right ObjectIdFieldType
    proj "Array" = Right ArrayFieldType
    proj "Object" = Right ObjectFieldType
    proj "SQL² Identifier" = Right SqlIdentifierFieldType
    proj "SQL² Expression" = Right SqlExprFieldType
    proj t = Left t

fieldTypeToInputType
  ∷ FieldType
  → HP.InputType
fieldTypeToInputType ty =
  case ty of
    StringFieldType → HP.InputText
    DateTimeFieldType → HP.InputDatetimeLocal
    DateFieldType → HP.InputDate
    TimeFieldType → HP.InputTime
    IntervalFieldType → HP.InputText
    BooleanFieldType → HP.InputCheckbox
    NumericFieldType → HP.InputNumber
    ObjectIdFieldType → HP.InputText
    ArrayFieldType → HP.InputText
    ObjectFieldType → HP.InputText
    SqlExprFieldType → HP.InputText
    SqlIdentifierFieldType → HP.InputText

-- PLEASE REMEMBER: do not change these tags!
instance encodeJsonFieldType ∷ JE.EncodeJson FieldType where
  encodeJson ty =
    J.fromString
      case ty of
        StringFieldType → "string"
        DateTimeFieldType → "datetime"
        DateFieldType → "date"
        TimeFieldType → "time"
        IntervalFieldType → "interval"
        BooleanFieldType → "boolean"
        NumericFieldType → "numeric"
        ObjectIdFieldType → "objectId"
        ArrayFieldType → "array"
        ObjectFieldType → "object"
        SqlExprFieldType → "query"
        SqlIdentifierFieldType → "sql-identifier"

instance decodeJsonFieldType ∷ JD.DecodeJson FieldType where
  decodeJson =
    J.decodeJson >=> proj
    where
      proj "string" = Right StringFieldType
      proj "date" = Right DateFieldType
      proj "time" = Right TimeFieldType
      proj "interval" = Right IntervalFieldType
      proj "datetime" = Right DateTimeFieldType
      proj "boolean" = Right BooleanFieldType
      proj "numeric" = Right NumericFieldType
      proj "objectId" = Right ObjectIdFieldType
      proj "orderedSet" = Right ArrayFieldType -- for compatibility
      proj "array" = Right ArrayFieldType
      proj "object" = Right ObjectFieldType
      proj "query" = Right SqlExprFieldType
      proj "sql-identifier" = Right SqlIdentifierFieldType
      proj _ = Left "invalid FieldType"

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.FormBuilder.Item.FieldType
  ( FieldType(..)
  , allFieldTypes
  , _FieldTypeDisplayName
  , fieldTypeToInputType
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Argonaut.Decode as JD
import Data.Argonaut.Encode as JE
import Data.Lens as Lens
import Data.List as L

import Halogen.HTML.Properties as HP

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

data FieldType
  = StringFieldType
  | BooleanFieldType
  | NumericFieldType
  | DateTimeFieldType
  | DateFieldType
  | TimeFieldType
  | IntervalFieldType
  | ObjectIdFieldType
  | ArrayFieldType
  | ObjectFieldType
  | SqlExprFieldType
  | SqlIdentifierFieldType

derive instance genericFieldType ∷ Generic FieldType
derive instance eqFieldType ∷ Eq FieldType
derive instance ordFieldType ∷ Ord FieldType

instance arbitraryFieldType ∷ SC.Arbitrary FieldType where
  arbitrary =
    Gen.elements
      StringFieldType
      (L.fromFoldable allFieldTypes)

allFieldTypes ∷ Array FieldType
allFieldTypes =
  [ StringFieldType
  , DateTimeFieldType
  , DateFieldType
  , TimeFieldType
  , IntervalFieldType
  , BooleanFieldType
  , NumericFieldType
  , ObjectIdFieldType
  , ArrayFieldType
  , ObjectFieldType
  , SqlExprFieldType
  , SqlIdentifierFieldType
  ]

_FieldTypeDisplayName ∷ Lens.Prism' String FieldType
_FieldTypeDisplayName = Lens.prism inj proj
  where
    inj StringFieldType = "Text"
    inj DateTimeFieldType = "DateTime"
    inj DateFieldType = "Date"
    inj TimeFieldType = "Time"
    inj IntervalFieldType = "Interval"
    inj BooleanFieldType = "Boolean"
    inj NumericFieldType = "Numeric"
    inj ObjectIdFieldType = "Object ID"
    inj ArrayFieldType = "Array"
    inj ObjectFieldType = "Object"
    inj SqlExprFieldType = "SQL² Expression"
    inj SqlIdentifierFieldType = "SQL² Identifier"

    proj "Text" = Right StringFieldType
    proj "DateTime" = Right DateTimeFieldType
    proj "Date" = Right DateFieldType
    proj "Time" = Right TimeFieldType
    proj "Interval" = Right IntervalFieldType
    proj "Boolean" = Right BooleanFieldType
    proj "Numeric" = Right NumericFieldType
    proj "Object ID" = Right ObjectIdFieldType
    proj "Array" = Right ArrayFieldType
    proj "Object" = Right ObjectFieldType
    proj "SQL² Identifier" = Right SqlIdentifierFieldType
    proj "SQL² Expression" = Right SqlExprFieldType
    proj t = Left t

fieldTypeToInputType
  ∷ FieldType
  → HP.InputType
fieldTypeToInputType ty =
  case ty of
    StringFieldType → HP.InputText
    DateTimeFieldType → HP.InputDatetimeLocal
    DateFieldType → HP.InputDate
    TimeFieldType → HP.InputTime
    IntervalFieldType → HP.InputText
    BooleanFieldType → HP.InputCheckbox
    NumericFieldType → HP.InputNumber
    ObjectIdFieldType → HP.InputText
    ArrayFieldType → HP.InputText
    ObjectFieldType → HP.InputText
    SqlExprFieldType → HP.InputText
    SqlIdentifierFieldType → HP.InputText

-- PLEASE REMEMBER: do not change these tags!
instance encodeJsonFieldType ∷ JE.EncodeJson FieldType where
  encodeJson ty =
    J.fromString
      case ty of
        StringFieldType → "string"
        DateTimeFieldType → "datetime"
        DateFieldType → "date"
        TimeFieldType → "time"
        IntervalFieldType → "interval"
        BooleanFieldType → "boolean"
        NumericFieldType → "numeric"
        ObjectIdFieldType → "objectId"
        ArrayFieldType → "array"
        ObjectFieldType → "object"
        SqlExprFieldType → "query"
        SqlIdentifierFieldType → "sql-identifier"

instance decodeJsonFieldType ∷ JD.DecodeJson FieldType where
  decodeJson =
    J.decodeJson >=> proj
    where
      proj "string" = Right StringFieldType
      proj "date" = Right DateFieldType
      proj "time" = Right TimeFieldType
      proj "interval" = Right IntervalFieldType
      proj "datetime" = Right DateTimeFieldType
      proj "boolean" = Right BooleanFieldType
      proj "numeric" = Right NumericFieldType
      proj "objectId" = Right ObjectIdFieldType
      proj "orderedSet" = Right ArrayFieldType -- for compatibility
      proj "array" = Right ArrayFieldType
      proj "object" = Right ObjectFieldType
      proj "query" = Right SqlExprFieldType
      proj "sql-identifier" = Right SqlIdentifierFieldType
      proj _ = Left "invalid FieldType"


illustrating the problem of Transition types

Transition is fundamentally untyped…it’s a problem…

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  erg <- d3Transition "erg"
    .. duration 750.0

  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition
      -- .. duration 750.0

  chart1 ... savedTransition erg  -- works because the transition gets type (Transition Number) from chart1

  chart2 ... savedTransition erg  -- doesn't work because this needs to be (Transition String)

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  d3Transition "erg"
    .. duration 750.0

  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition

  chart1 ... namedTransition "erg"
  chart2 ... namedTransition "erg"

  pure unit


remove unused var

remove unused var

module Request.GetStampRally (getStampRally) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.GetStampRallyResponse (GetStampRallyResponse)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)

getStampRally :: forall eff
               . String
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) GetStampRallyResponse
getStampRally stampRallyId token = do
  text <- fetch options
  let f = readJSON text :: F GetStampRallyResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    url = ( "https://api.rallyapp.jp/stamp_rallies/"
          <> stampRallyId
          <> "?view_type=admin"
          )
    options = FetchOptions.method := FetchOptions.GET
              <> FetchOptions.url := url
              <> FetchOptions.headers := headers

module Request.GetStampRally (getStampRally) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.GetStampRallyResponse (GetStampRallyResponse)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, pure, show)

getStampRally :: forall eff
               . String
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) GetStampRallyResponse
getStampRally stampRallyId token = do
  text <- fetch options
  let f = readJSON text :: F GetStampRallyResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    url = ( "https://api.rallyapp.jp/stamp_rallies/"
          <> stampRallyId
          <> "?view_type=admin"
          )
    options = FetchOptions.method := FetchOptions.GET
              <> FetchOptions.url := url
              <> FetchOptions.headers := headers


Wrapping Country in newtype

Wrapping Country in newtype

module Flag.Core (Event, Country, view, foldp, init) where

import Prelude hiding (div)
import Data.Maybe (Maybe(..))
import Data.Array (uncons, length, replicate, zip, sortBy, drop, head)
import Control.Monad.Eff.Exception (Error)
import Data.Either (Either(..))
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Aff (liftEff')
import Data.Tuple (Tuple(..), fst)
import Data.Traversable (sequence)
import Data.Foldable (for_)
import Pux (EffModel, noEffects)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick)
import Text.Smolder.HTML (h1, img, button, ul, li, div)
import Text.Smolder.Markup (text, (!), (#!))
import Text.Smolder.HTML.Attributes (src, alt, className, disabled)

type Name = String
type Countries = Array Country
type State = { countries ∷ Countries, correct ∷ Int, incorrect ∷ Int }

data Event = Answer Name | RequestCountries | ReceiveCountries (Either Error Countries)
newtype Country = Country { name :: Name, flag :: String }

init ∷ State
init = { countries: [], correct: 0, incorrect: 0 }

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM)
foldp (Answer name) st = noEffects $ case head st.countries of
  Nothing              -> st { countries = [], correct = 0, incorrect = 0 }
  Just (Country model) -> if name == model.name then isCorrect else isIncorrect
    where
      countries   = drop 1 st.countries
      isCorrect   = st { countries = countries, correct = st.correct + 1 }
      isIncorrect = st { countries = countries, incorrect = st.incorrect + 1 }
foldp (ReceiveCountries (Left err)) st = noEffects $ st { countries = [] }
foldp (ReceiveCountries (Right xs)) st = noEffects $ st { countries = xs }
foldp (RequestCountries)            st = { state: st, effects: [do
  xs <- liftEff' $ map fst <$> sortBy compareSnd <$> pairs
  pure $ Just $ ReceiveCountries xs
]}
  where
    pairs = zip countries <$> (sequence $ replicate (length countries) random)
    compareSnd (Tuple _ a) (Tuple _ b) = compare a b
    countries = [
      Country { name: "Russia", flag: "russia.svg" },
      Country { name: "Japan", flag: "japan.svg" },
      Country { name: "Thailand", flag: "thailand.svg" }
    ]

view ∷ State → HTML Event
view state = div ! className "flagship" $ case uncons state.countries of
  Nothing -> toolbar state
  Just _  -> toolbar state <> flag state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button ! disabled isDisabled #! onClick (const RequestCountries) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    where
      isDisabled = if (length state.countries == 0) then "" else "disabled"

flag ∷ State → HTML Event
flag state = div ! className "prompt" $ do
  case head state.countries of
    Nothing              -> div $ text "All done!"
    Just (Country model) -> do
      img ! src ("images/flags/" <> model.flag) ! alt "Flag"
      ul ! className "countries" $ for_ state.countries $ country

country ∷ Country → HTML Event
country (Country model) =
  li $ button #! onClick (const $ Answer model.name) $ text model.name

module Flag.Core (Event, view, foldp, init) where

import Prelude hiding (div)
import Data.Maybe (Maybe(..))
import Data.Array (uncons, length, replicate, zip, sortBy, drop, head)
import Control.Monad.Eff.Exception (Error)
import Data.Either (Either(..))
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Aff (liftEff')
import Data.Tuple (Tuple(..), fst)
import Data.Traversable (sequence)
import Data.Foldable (for_)
import Pux (EffModel, noEffects)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick)
import Text.Smolder.HTML (h1, img, button, ul, li, div)
import Text.Smolder.Markup (text, (!), (#!))
import Text.Smolder.HTML.Attributes (src, alt, className, disabled)

type Name = String
type Countries = Array Country
type State = { countries ∷ Countries, correct ∷ Int, incorrect ∷ Int }
type Country = { name :: Name, flag :: String }

data Event = Answer Name | RequestCountries | ReceiveCountries (Either Error Countries)

init ∷ State
init = { countries: [], correct: 0, incorrect: 0 }

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM)
foldp (Answer name) st = noEffects $ case head st.countries of
  Nothing    -> st { countries = [], correct = 0, incorrect = 0 }
  Just model -> if name == model.name then isCorrect else isIncorrect
    where
      countries   = drop 1 st.countries
      isCorrect   = st { countries = countries, correct = st.correct + 1 }
      isIncorrect = st { countries = countries, incorrect = st.incorrect + 1 }
foldp (ReceiveCountries (Left err)) st = noEffects $ st { countries = [] }
foldp (ReceiveCountries (Right xs)) st = noEffects $ st { countries = xs }
foldp (RequestCountries)            st = { state: st, effects: [do
  xs <- liftEff' $ map fst <$> sortBy compareSnd <$> pairs
  pure $ Just $ ReceiveCountries xs
]}
  where
    pairs = zip countries <$> (sequence $ replicate (length countries) random)
    compareSnd (Tuple _ a) (Tuple _ b) = compare a b
    countries = [
      { name: "Russia", flag: "russia.svg" },
      { name: "Japan", flag: "japan.svg" },
      { name: "Thailand", flag: "thailand.svg" }
    ]

view ∷ State → HTML Event
view state = div ! className "flagship" $ case uncons state.countries of
  Nothing -> toolbar state
  Just _  -> toolbar state <> flag state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button ! disabled isDisabled #! onClick (const RequestCountries) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    where
      isDisabled = if (length state.countries == 0) then "" else "disabled"

flag ∷ State → HTML Event
flag state = div ! className "prompt" $ do
  case head state.countries of
    Just model -> do
      img ! src ("images/flags/" <> model.flag) ! alt "Flag"
      ul ! className "countries" $ for_ state.countries $ choice
    Nothing   -> div $ text "All done!"

choice ∷ Country → HTML Event
choice model = li $ button #! onClick (const $ Answer model.name) $ text model.name


Updated unit tests

Updated unit tests

module Test.Main where

import Prelude (Unit, bind, ($), (>>=), pure, unit, const)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Aff (Aff, launchAff, liftEff', Canceler)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (log) as AffLog
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Coroutine (Consumer, Producer, Process, ($$), runProcess, await)
import Control.Coroutine.Aff (produce)
import FFI.Util (parseOptions, require, stringify)
import FFI.Util.Log (logAny)
import FFI.Util.Function (call0, call1, callAff2r1, listenToEff0)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | Define some data types for the FFI libraries
foreign import data FileSystemM :: *
foreign import data Stream :: *
foreign import data FS :: !   -- To keep track of file system side effects

foreign import data BufferM :: *
foreign import data Buffer :: *
foreign import data BUFFER :: !  -- To keep track of buffer side effects

-- | We can require() modules directly and easily
-- | As a convention, module data types are suffixed with M
fs :: FileSystemM
fs = require "fs"

buffer :: BufferM
buffer = require "buffer"

-- | It becomes easy to convert a JS function into a PS one
-- | From the 'buffer' module:
toBuffer :: forall e. String -> Eff (err :: EXCEPTION, buffer :: BUFFER | e) Buffer
toBuffer s = pure $ call1 buffer "Buffer" s

toString :: forall e. Buffer -> Eff (err :: EXCEPTION, buffer :: BUFFER | e) String
toString b = pure $ call0 b "toString"

-- | From the 'fs' module:
readFile :: forall e. String -> Aff (fs :: FS | e) String
readFile file = callAff2r1 fs "readFile" file "utf8"

createReadStream :: forall e. String -> Eff (err :: EXCEPTION, fs :: FS | e) Stream
createReadStream file = pure $ call1 fs "createReadStream" file

-- | We can have objects that use Maybe types to convey optional values
type SomeConfigObject = { foo :: String, bar :: { baz :: Maybe Int, qux :: Boolean } }

config1 :: SomeConfigObject
config1 = { foo: "bar", bar: { baz: Nothing, qux: true } }

config2 :: SomeConfigObject
config2 = { foo: "bar", bar: { baz: Just 3, qux: true } }

-- | We can easily listen to events
-- | In this example coroutines are used to encapsulate the set of events for Streams
data StreamEvent = Readable | Data | End

streamProducer :: forall e. Stream -> Producer StreamEvent (Aff (avar :: AVAR | e)) Unit
streamProducer stream = produce \emit -> do
  listenToEff0 stream "on" "readable" \_ -> emit (Left Readable)
  listenToEff0 stream "on" "data"     \_ -> emit (Left Data)
  listenToEff0 stream "on" "end"      \_ -> do
    emit (Left End)
    emit (Right unit)

streamConsumer :: forall e. Consumer StreamEvent (Aff (console :: CONSOLE | e)) Unit
streamConsumer = forever do
  e <- await
  case e of
    Readable -> lift $ AffLog.log "Readable event fired"
    Data     -> lift $ AffLog.log "Data event fired"
    End      -> lift $ AffLog.log "End event fired"

streamProcess :: forall e. Stream -> Process (Aff (console :: CONSOLE, avar :: AVAR | e)) Unit
streamProcess stream = (streamProducer stream) $$ (streamConsumer)

main :: forall e
      . Eff (fs :: FS, console :: CONSOLE, avar :: AVAR, buffer :: BUFFER, err :: EXCEPTION | e)
        (Canceler (fs :: FS, console :: CONSOLE, avar :: AVAR, buffer :: BUFFER | e))
main = do
  log $ stringify false $ parseOptions config1  -- {"foo":"bar","bar":{"qux":true}}
  log $ stringify false $ parseOptions config2  -- {"foo":"bar","bar":{"baz":3,"qux":true}}

  toBuffer "foobar" >>= \buf -> do
    logAny buf            -- <Buffer 66 6f 6f 62 61 72>
    buf' <- toString buf  -- foobar
    log buf'

  -- | Launch the stream coroutine
  launchAff $ do
    stream <- liftEff' $ createReadStream "/home/pureuser/src/bower.json"
    either (const $ pure unit) (\s -> runProcess (streamProcess s)) stream

  -- | Outputs the contents of bower.json to stdout
  launchAff $ do
    contents <- readFile "/home/pureuser/src/bower.json"
    AffLog.log contents

module Test.Main where

import Prelude (Unit, bind, ($), (>>=), pure, unit, const)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Aff (Aff, launchAff, liftEff', Canceler)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (log) as AffLog
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Coroutine (Consumer, Producer, Process, ($$), runProcess, await)
import Control.Coroutine.Aff (produce)
import FFI.Util (parseOptions, require, stringify)
import FFI.Util.Log (logAny)
import FFI.Util.Function (call0, call1, callAff2r1, listenToEff0)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | Define some data types for the FFI libraries
foreign import data FileSystemM :: *
foreign import data Stream :: *
foreign import data FS :: !   -- To keep track of file system side effects

foreign import data BufferM :: *
foreign import data Buffer :: *
foreign import data BUFFER :: !  -- To keep track of buffer side effects

-- | We can require() modules directly and easily
-- | As a convention, module data types are suffixed with M
fs :: FileSystemM
fs = require "fs"

buffer :: BufferM
buffer = require "buffer"

-- | It becomes easy to convert a JS function into a PS one
-- | From the 'buffer' module:
toBuffer :: forall e. String -> Eff (err :: EXCEPTION, buffer :: BUFFER | e) Buffer
toBuffer s = pure $ call1 buffer "Buffer" s

toString :: forall e. Buffer -> Eff (err :: EXCEPTION, buffer :: BUFFER | e) String
toString b = pure $ call0 b "toString"

-- | From the 'fs' module:
readFile :: forall e. String -> Aff (fs :: FS | e) String
readFile file = callAff2r1 fs "readFile" file "utf8"

createReadStream :: forall e. String -> Eff (err :: EXCEPTION, fs :: FS | e) Stream
createReadStream file = pure $ call1 fs "createReadStream" file

-- | We can have objects that use Maybe types to convey optional values
type SomeConfigObject = { foo :: String, bar :: { baz :: Maybe Int, qux :: Boolean } }

config1 :: SomeConfigObject
config1 = { foo: "bar", bar: { baz: Nothing, qux: true } }

config2 :: SomeConfigObject
config2 = { foo: "bar", bar: { baz: Just 3, qux: true } }

-- | We can easily listen to events
-- | In this example coroutines are used to encapsulate the set of events for Streams
data StreamEvent = Readable | Data | End

streamProducer :: forall e. Stream -> Producer StreamEvent (Aff (avar :: AVAR | e)) Unit
streamProducer zz = produce \emit -> do
  listenToEff0 zz "on" "readable" \_ -> emit (Left Readable)
  listenToEff0 zz "on" "data"     \_ -> emit (Left Data)
  listenToEff0 zz "on" "end"      \_ -> do
    emit (Left End)
    emit (Right unit)

streamConsumer :: forall e. Consumer StreamEvent (Aff (console :: CONSOLE | e)) Unit
streamConsumer = forever do
  e <- await
  case e of
    Readable -> lift $ AffLog.log "Readable event fired"
    Data     -> lift $ AffLog.log "Data event fired"
    End      -> lift $ AffLog.log "End event fired"

streamProcess :: forall e. Stream -> Process (Aff (console :: CONSOLE, avar :: AVAR | e)) Unit
streamProcess stream = (streamProducer stream) $$ (streamConsumer)

main :: forall e
      . Eff (fs :: FS, console :: CONSOLE, avar :: AVAR, buffer :: BUFFER, err :: EXCEPTION | e)
        (Canceler (fs :: FS, console :: CONSOLE, avar :: AVAR, buffer :: BUFFER | e))
main = do
  log $ stringify false $ parseOptions config1  -- {"foo":"bar","bar":{"qux":true}}
  log $ stringify false $ parseOptions config2  -- {"foo":"bar","bar":{"baz":3,"qux":true}}

  toBuffer "foobar" >>= \buf -> do
    logAny buf            -- <Buffer 66 6f 6f 62 61 72>
    buf' <- toString buf  -- foobar
    log buf'

  -- | Launch the stream coroutine
  launchAff $ do
    stream <- liftEff' $ createReadStream "/home/pureuser/src/bower.json"
    either (const $ pure unit) (\s -> runProcess (streamProcess s)) stream

  -- | Outputs the contents of bower.json to stdout
  launchAff $ do
    contents <- readFile "/home/pureuser/src/bower.json"
    AffLog.log contents


Better logging

Better logging

module Benchotron
  ( Benchmark()
  , runBenchmark
  , benchmarkToFile
  , benchmarkToStdout
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  , Stats()
  , Any()
  , toAny
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception())
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

type Benchmark e a =
  { name               :: String
  , sizes              :: Array Number
  , sizeInterpretation :: String
  , inputsPerSize      :: Number
  , gen                :: Number -> Eff (BenchEffects e) a
  , functions          :: Array { name :: String, fn :: a -> Any }
  }

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) BenchmarkResult
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [" Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
      let f _ = map function.fn inputs
      stats <- runBenchmarkImpl f
      return { name: function.name, stats: stats }

    return { size: size, allStats: allStats }

  stderrWrite "\n"
  let series = rejig results
  return
    { name: benchmark.name
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results
  stderrWrite $ "Benchmark \""<> bench.name <> "\" results written to " <> path <> "\n"

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type BenchmarkResult =
  { name               :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Number
  , stats :: Stats
  }

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(fn) {
    var Benchmark = require('benchmark')
    return function() {
      return Benchmark(fn).run().stats
    }
  }
  """ :: forall e r. (Unit -> r) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: BenchmarkResult -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

module Benchotron
  ( Benchmark()
  , runBenchmark
  , benchmarkToFile
  , benchmarkToStdout
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  , Stats()
  , Any()
  , toAny
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception())
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

type Benchmark e a =
  { name               :: String
  , sizes              :: Array Number
  , sizeInterpretation :: String
  , inputsPerSize      :: Number
  , gen                :: Number -> Eff (BenchEffects e) a
  , functions          :: Array { name                     :: String, fn :: a -> Any }
  }

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) BenchmarkResult
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [" Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
      let f _ = map function.fn inputs
      stats <- runBenchmarkImpl f
      return { name: function.name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { name: benchmark.name
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type BenchmarkResult =
  { name               :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Number
  , stats :: Stats
  }

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(fn) {
    var Benchmark = require('benchmark')
    return function() {
      return Benchmark(fn).run().stats
    }
  }
  """ :: forall e r. (Unit -> r) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: BenchmarkResult -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit