Fix Track config fallthrough

Fix Track config fallthrough

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , makeBDTrack
       , validateBDConfig
       , CyGraphConfig
       , makeCyTrack
       , validateCyConfig
       , TrackType
       )
       where

import Prelude
import Data.Argonaut (Json, _Object, _String)
import Data.Either (Either(..))
import Data.Foreign (Foreign, toForeign)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))

newtype TrackType = TrackType String

-- derive instance newtypeTrackType :: Newtype TrackType _
derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType

bdTrack = TrackType "BDTrack"
cyGraph = TrackType "CyGraph"

getTrackType :: Json -> Maybe TrackType
getTrackType json = case json ^? _Object <<< ix "trackType" <<< _String of
  -- must be better ways of encoding this. this is ripe for programmer error
  Just "BDTrack" -> Just bdTrack
  Just "CyGraph" -> Just cyGraph
  _ -> Nothing

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { trackType :: TrackType, name :: String | r } -> BDTrackConfig
makeBDTrack = BDTrackConfig <<< toForeign

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json =
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just (TrackType "CyGraph") -> Left $ "Is CyGraph"
    Just (TrackType "BDTrack") -> case json ^? _Object <<< ix "name" of
      Nothing -> Left $ "BD track config does not have a name"
      Just c  -> Right $ BDTrackConfig $ toForeign json
    Just _ -> Left $ "Track has unrecognized type"

-- Maybe this should be in another file (one not called 'Track')
newtype CyGraphConfig = CyGraphConfig Foreign

makeCyTrack :: ∀ r. { trackType :: TrackType, elementsUri :: String | r } -> CyGraphConfig
makeCyTrack = CyGraphConfig <<< toForeign

-- this and validateBDConfig must be able to be simplified;
-- there are two levels of validation, first checking it's a track at all,
-- then validating the specific track type
validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = do
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just (TrackType "BDTrack") -> Left $ "Is BD track"
    Just (TrackType "CyGraph") -> case json ^? _Object <<< ix "elementsUri" of
      Nothing -> Left $ "cy graph config does not have an elementsUri"
      Just c  -> Right $ CyGraphConfig $ toForeign json
    Just _ -> Left $ "Track has unrecognized type"

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , makeBDTrack
       , validateBDConfig
       , CyGraphConfig
       , makeCyTrack
       , validateCyConfig
       , TrackType
       )
       where

import Prelude
import Data.Argonaut (Json, _Object, _String)
import Data.Either (Either(..))
import Data.Foreign (Foreign, toForeign)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))

newtype TrackType = TrackType String

-- derive instance newtypeTrackType :: Newtype TrackType _
derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType

bdTrack = TrackType "BDTrack"
cyGraph = TrackType "CyGraph"

getTrackType :: Json -> Maybe TrackType
getTrackType json = case json ^? _Object <<< ix "trackType" <<< _String of
  -- must be better ways of encoding this. this is ripe for programmer error
  Just "BDTrack" -> Just bdTrack
  Just "CyGraph" -> Just cyGraph
  _ -> Nothing

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { trackType :: TrackType, name :: String | r } -> BDTrackConfig
makeBDTrack = BDTrackConfig <<< toForeign

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json =
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just cyGraph -> Left $ ""
    Just bdTrack -> case json ^? _Object <<< ix "name" of
      Nothing -> Left $ "BD track config does not have a name"
      Just c  -> Right $ BDTrackConfig $ toForeign json

-- Maybe this should be in another file (one not called 'Track')
newtype CyGraphConfig = CyGraphConfig Foreign

makeCyTrack :: ∀ r. { trackType :: TrackType, elementsUri :: String } -> CyGraphConfig
makeCyTrack = CyGraphConfig <<< toForeign

-- this and validateBDConfig must be able to be simplified;
-- there are two levels of validation, first checking it's a track at all,
-- then validating the specific track type
validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = do
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just bdTrack -> Left $ ""
    Just cyGraph -> case json ^? _Object <<< ix "elementsUri" of
      Nothing -> Left $ "cy graph config does not have an elementsUri"
      Just c  -> Right $ CyGraphConfig $ toForeign json

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)


New types again. Woo!!

New types again. Woo!!

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse_)
import Data.Tuple (Tuple(..))
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

-- Given a score range,
-- size of the current chr + scale (scale should be somewhere else...)
-- vertical size of the track
-- we can produce a mapping from canvases to SingleGlyph renderers

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = Tuple <$> ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames (Array _)
      fs = frames w 20.0 (const size) (Array.replicate 5 as)

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse_)
import Data.Tuple (Tuple(..))
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

newtype ChrRenderParams =
  ChrRenderParams
    (Maybe { xOffset :: Pixels
           , yOffset :: Pixels
           , height :: Pixels })

-- A Renderer maps data attached to a chromosome id to
-- a way to render said data,
-- when provided some extra information on where and how to render it
type Renderer eff a = { chrId :: ChrId, features :: Array a }
                   -> ChrRenderParams -> Eff eff Unit

-- I get the feeling using all of these renderers is going to be a hylomorphism...

chrRenderParams :: { xOffset :: Number, xDist :: Number }
                -> (ChrId -> Number)
                -> ChrId
                -> ChrRenderParams
chrRenderParams { xOffset, xDist } chrIndex chrId = ChrRenderParams $
  Just { xOffset: xOffset+xDist*(chrIndex chrId), yOffset: 0.0, height: 0.0 }

-- given a position on the chromosome, the size of the chromosome,
-- and the scale,
-- return the canvas X-coordinate
posPixelsX :: Bp
           -> Bp
           -> BpPerPixel
           -> Pixels
posPixelsX pos size scale = bpToPixels scale (pos / size)

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
posPixelsY :: Number
           -> Pixels
           -> Pixels
           -> Pixels
posPixelsY rel height offset = rel * height + offset

data RenderType eff a =
    SingleGlyph (a -> { translateX :: Number, translateY :: Number }) (Eff eff Unit)
  | ManyGlyphs (a -> { translateX :: Number, translateY :: Number }) (a -> Eff eff Unit)
  | Connected (Array a -> Eff eff Unit)

-- Given a score range,
-- size of the current chr + scale (scale should be somewhere else...)
-- vertical size of the track
-- we can produce a mapping from canvases to SingleGlyph renderers
renderGWAS :: forall r.
              { minScore :: Number, maxScore :: Number }
           -> { size :: Bp, scale :: BpPerPixel }
           -> { trackHeight :: Pixels, trackYOffset :: Pixels }
           -> Context2D
           -> RenderType _ {score :: Number, pos :: Bp | r }
renderGWAS scoreRange hInfo vInfo ctx = SingleGlyph t f
  where f = renderGlyph ctx (circle { x: 0.0, y: 0.0 } 3.0 )
        t {pos,score} = let translateX = posPixelsX pos hInfo.size hInfo.scale
                            translateY = posPixelsY ((score - scoreRange.minScore) /
                                              (scoreRange.maxScore - scoreRange.minScore))
                                          vInfo.trackHeight vInfo.trackYOffset
                        in {translateX, translateY}

-- this one's weird, since the context changes... but close enough for now
renderChr :: forall a.
             RenderType _ a
          -> Context2D
          -> Array a
          -> Eff _ Unit
renderChr (SingleGlyph t draw) ctx =
  traverse_ (\a -> C.withContext ctx (C.translate (t a) ctx *> draw))
renderChr (ManyGlyphs t f) ctx =
  traverse_ (\a -> C.withContext ctx (C.translate (t a) ctx *> f a))
renderChr (Connected f) _ = f

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }

renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = Tuple <$> ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames (Array _)
      fs = frames w 20.0 (const size) (Array.replicate 5 as)

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

fetchTrack :: forall r a.
              Track _ _ a
           -> Range r
           -> Aff _ (Array a)
fetchTrack track r = track.source.fetch r.lHand r.rHand
main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}


Enforce EOF at end of usage section parse

module Language.Docopt.Parser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Parser.Usage.Option as O
import Language.Docopt.Parser.Usage.Usage as U
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Bind ((=<<))
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Data.Either (Either)
import Data.List (List(..), many, some, singleton, length, modifyAt)
import Data.Maybe (fromMaybe, Maybe(..), maybe, isNothing)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested (tuple3)
import Language.Docopt.Parser.Common (markIndent', markLine, indented,
                                     sameIndent, lessIndented, moreIndented)
import Language.Docopt.Parser.Usage.Argument (Argument(..))
import Language.Docopt.Parser.Usage.Usage (Usage(..))
import Text.Parsing.Parser (ParseError) as P
import Text.Parsing.Parser.Combinators (try, optional, choice, sepBy1, between,
                                       lookAhead) as P
import Text.Parsing.Parser.Combinators ((<?>), (<??>))
import Text.Parsing.Parser.Pos (Position(Position)) as P

-- | TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: Boolean -- ^ Enable "smart-options" parsing
            -> L.TokenParser (List Usage)
usageParser smartOpts = do

  -- Calculate and mark the original program indentation.
  P.Position { column: startCol } <- L.nextTokPos <?> "Program name"
  name <- program
  markLine do
    markIndent' startCol $ do
      Cons
      <$> (usageLine name)
      <*> many do
            P.optional $ P.try do
              L.name >>= guard <<< (_ == "or")
              L.colon
            program
            usageLine name
  <* (L.eof <?> "End of usage section")

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs <- "Option, Positional, Command, Group or Reference elements" <??> do
                  (many $ P.try $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          moreIndented *> L.doubleDash
          P.optional do
            many elem
          return $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          return Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        <?> "End of usage line"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      return $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as ++ (singleton e))
          xs

    elem :: L.TokenParser Argument
    elem = defer \_ -> do
      P.choice $ P.try <$>
        [ option
        , positional
        , command
        , (if smartOpts then trySmartOpt else id) <$> group
        , reference
        , stdin
        ] <?> "Option, Positional, Command, Group or Reference"

    trySmartOpt :: Argument -> Argument
    trySmartOpt grp@(Group oo bs r) = fromMaybe grp $ do
      Tuple opt optarg <- case bs of
                              (Cons (Cons opt' (Cons arg' Nil)) Nil) ->
                                return $ Tuple opt' arg'
                              otherwise -> Nothing

      optf <- do
        case opt of
              (Option (O.LOpt o)) | isNothing o.arg ->
                return $ \argName isArgOptional isRepeatable ->
                  Option $ O.LOpt $ o {
                    arg = return {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              (OptionStack (O.SOpt o)) | isNothing o.arg ->
                return $ \argName isArgOptional isRepeatable ->
                  OptionStack $ O.SOpt $ o {
                    arg = return {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              otherwise -> Nothing

      (Tuple (Tuple name isRepeatable) isOptional) <- do
        case optarg of
              (Positional n r') -> return $ tuple3 n (r' || r) false
              (Command    n r') -> return $ tuple3 n (r' || r) false
              (Group o (Cons (Cons a Nil) Nil) r) ->
                case a of
                  (Positional n r') -> return $ tuple3 n (r' || r) o
                  (Command    n r') -> return $ tuple3 n (r' || r) o
                  otherwise -> Nothing
              otherwise -> Nothing
      return
        $ Group oo
                (singleton $ singleton (optf name isOptional isRepeatable))
                r
    trySmartOpt x = x

    stdin :: L.TokenParser Argument
    stdin = L.dash *> return Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name: name, arg: arg } <- L.lopt
      O.lopt' name arg <$> repetition

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag: flag, stack: stack, arg: arg } <- L.sopt
      O.sopt' flag stack arg <$> repetition

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional
      <$> (L.angleName <|> L.shoutName)
      <*> repetition

    command :: L.TokenParser Argument
    command = Command
      <$> L.name
      <*> repetition

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice [ reqGroup , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> L.lsquare)
            (L.rsquare)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> L.lparen)
            (L.rparen)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    repetition :: L.TokenParser Boolean
    repetition = P.choice
      [ P.try $ indented *> L.tripleDot *> return true
      , return false ]

    program :: L.TokenParser String
    program = "Program name" <??> L.name

parse :: Boolean                  -- ^ Enable "smart-options"
      -> (List L.PositionedToken) -- ^ The token stream
      -> Either P.ParseError (List Usage)
parse smartOpts = flip L.runTokenParser (usageParser smartOpts)

run :: String  -- ^ The usage section text
    -> Boolean -- ^ Enable "smart-options"
    -> Either P.ParseError (List Usage)
run x smartOpts = parse smartOpts =<< L.lexUsage x

module Language.Docopt.Parser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Language.Docopt.Parser.Lexer as L
import Language.Docopt.Parser.Usage.Option as O
import Language.Docopt.Parser.Usage.Usage as U
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Data.Either (Either)
import Data.List (List(..), many, some, singleton, length, modifyAt)
import Data.Maybe (fromMaybe, Maybe(..), maybe, isNothing)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested (tuple3)
import Language.Docopt.Parser.Common (markIndent', markLine, indented,
                                     sameIndent, lessIndented, moreIndented)
import Language.Docopt.Parser.Usage.Argument (Argument(..))
import Language.Docopt.Parser.Usage.Usage (Usage(..))
import Text.Parsing.Parser (ParseError) as P
import Text.Parsing.Parser.Combinators (try, optional, choice, sepBy1, between,
                                       lookAhead) as P
import Text.Parsing.Parser.Combinators ((<?>), (<??>))
import Text.Parsing.Parser.Pos (Position(Position)) as P

-- | TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: Boolean -- ^ Enable "smart-options" parsing
            -> L.TokenParser (List Usage)
usageParser smartOpts = do

  -- Calculate and mark the original program indentation.
  P.Position { column: startCol } <- L.nextTokPos <?> "Program name"
  name <- program
  markLine do
    markIndent' startCol $ do
      Cons
      <$> (usageLine name)
      <*> many do
            P.optional $ P.try do
              L.name >>= guard <<< (_ == "or")
              L.colon
            P.try do
              program
              usageLine name

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs <- "Option, Positional, Command, Group or Reference elements" <??> do
                  (many $ P.try $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          moreIndented *> L.doubleDash
          return $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          return Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        <?> "start of next usage line or end of usage section"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      return $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as ++ (singleton e))
          xs

    elem :: L.TokenParser Argument
    elem = defer \_ -> do
      P.choice $ P.try <$>
        [ option
        , positional
        , command
        , (if smartOpts then trySmartOpt else id) <$> group
        , reference
        , stdin
        ] <?> "Option, Positional, Command, Group or Reference"

    trySmartOpt :: Argument -> Argument
    trySmartOpt grp@(Group oo bs r) = fromMaybe grp $ do
      Tuple opt optarg <- case bs of
                              (Cons (Cons opt' (Cons arg' Nil)) Nil) ->
                                return $ Tuple opt' arg'
                              otherwise -> Nothing

      optf <- do
        case opt of
              (Option (O.LOpt o)) | isNothing o.arg ->
                return $ \argName isArgOptional isRepeatable ->
                  Option $ O.LOpt $ o {
                    arg = return {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              (OptionStack (O.SOpt o)) | isNothing o.arg ->
                return $ \argName isArgOptional isRepeatable ->
                  OptionStack $ O.SOpt $ o {
                    arg = return {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              otherwise -> Nothing

      (Tuple (Tuple name isRepeatable) isOptional) <- do
        case optarg of
              (Positional n r') -> return $ tuple3 n (r' || r) false
              (Command    n r') -> return $ tuple3 n (r' || r) false
              (Group o (Cons (Cons a Nil) Nil) r) ->
                case a of
                  (Positional n r') -> return $ tuple3 n (r' || r) o
                  (Command    n r') -> return $ tuple3 n (r' || r) o
                  otherwise -> Nothing
              otherwise -> Nothing
      return
        $ Group oo
                (singleton $ singleton (optf name isOptional isRepeatable))
                r
    trySmartOpt x = x

    stdin :: L.TokenParser Argument
    stdin = L.dash *> return Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name: name, arg: arg } <- L.lopt
      O.lopt' name arg <$> repetition

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag: flag, stack: stack, arg: arg } <- L.sopt
      O.sopt' flag stack arg <$> repetition

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional
      <$> (L.angleName <|> L.shoutName)
      <*> repetition

    command :: L.TokenParser Argument
    command = Command
      <$> L.name
      <*> repetition

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice [ reqGroup , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> L.lsquare)
            (L.rsquare)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> L.lparen)
            (L.rparen)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    repetition :: L.TokenParser Boolean
    repetition = P.choice
      [ P.try $ indented *> L.tripleDot *> return true
      , return false ]

    program :: L.TokenParser String
    program = "Program name" <??> L.name

parse :: Boolean                  -- ^ Enable "smart-options"
      -> (List L.PositionedToken) -- ^ The token stream
      -> Either P.ParseError (List Usage)
parse smartOpts = flip L.runTokenParser (usageParser smartOpts)

run :: String  -- ^ The usage section text
    -> Boolean -- ^ Enable "smart-options"
    -> Either P.ParseError (List Usage)
run x smartOpts = parse smartOpts =<< L.lexUsage x


[CSE-168] Disable `Est. Volume` temporary

module Explorer.View.Block (blockView) where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)

import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)

import Network.RemoteData (RemoteData(..), isFailure)

import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)

import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.DOM.Events (onClick) as P

import Text.Smolder.HTML (a, div, h3, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!))

blockView :: State -> P.HTML Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    S.div ! S.className "explorer-block" $ do
        S.div ! S.className "explorer-block__wrapper"
              $ S.div ! S.className "explorer-block__container"  $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cBlock) lang')
                    case blockSummary of
                        NotAsked -> blockSummaryEmptyView ""
                        Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                        Success block -> blockSummaryView block lang'
        S.div ! S.className "explorer-block__wrapper" $ do
            S.div ! S.className "explorer-block__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang')
                case blockTxs of
                    NotAsked -> txEmptyContentView ""
                    Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                    Success txs -> blockTxsView txs state
            if (isFailure blockSummary && isFailure blockTxs)
                -- Show back button if both results ^ are failed
                then
                    S.div ! S.className "explorer-block__container"
                          $ S.a ! S.href (toUrl Dashboard)
                                #! P.onClick (Navigate $ toUrl Dashboard)
                                ! S.className "btn-back"
                                $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang')
                else
                    emptyView

--  summary

type SummaryRowItem =
    { id :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { id: "1"
      , label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    -- TODO: Enable it later again ([CSE-168] Remove `Est. Volume` temporary)
    -- , { id: "2"
    --   , label: translate (I18nL.block <<< I18nL.blEstVolume) lang
    --   -- TODO: We do need real data here
    --   , amount: formatADA (mkCoin "0") lang
    --   , mCurrency: Just ADA
    --   }
    , { id: "3"
      , label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { id: "4"
      , label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div ! S.className "row row__summary"
          ! P.key item.id
          $ do
          S.div ! S.className "column column__label"
                $ S.text item.label
          S.div ! S.className "column column__amount"
                $ if isJust item.mCurrency
                      then S.span ! S.className (currencyCSSClass item.mCurrency)
                                  $ S.text item.amount
                      else S.text item.amount

blockSummaryEmptyView :: String -> P.HTML Action
blockSummaryEmptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

blockSummaryView :: CBlockSummary -> Language -> P.HTML Action
blockSummaryView block lang =
    S.div ! S.className "blocks-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)) summaryRow
        S.div ! S.className "hashes-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cHashes) lang)
            S.div $ for_ (mkHashItems lang block) hashesRow

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { id :: String
    , label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { id: "1"
      , label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { id: "2"
      , label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { id: "3"
      , label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.HTML Action
hashesRow item =
    S.div ! S.className "row row__hashes"
          ! P.key item.id
          $ do
          S.div ! S.className "column column__label"
                $ S.text item.label
          case item.link of
              Nothing ->  S.div ! S.className "column column__hash"
                                $ S.text item.hash
              Just link -> S.a  ! S.href link
                                #! P.onClick (Navigate link)
                                ! S.className "column column__hash--link"
                                $ S.text item.hash

maxTxRows :: Int
maxTxRows = 5

blockTxsView :: CTxBriefs -> State -> P.HTML Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            lang' = state ^. lang
            minTxIndex = (txPagination - minPagination) * maxTxRows
            currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
        in
        S.div do
            S.div $ for_ currentTxs (\tx -> blockTxView tx lang')
            txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                              , currentPage: PageNumber txPagination
                              , minPage: PageNumber minPagination
                              , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                              , changePageAction: BlockPaginateTxs
                              , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                              , editableAction: BlockEditTxsPageNumber
                              , invalidPageAction: BlockInvalidTxsPageNumber
                              , disabled: false
                              }

blockTxView :: CTxBrief -> Language -> P.HTML Action
blockTxView tx lang =
    S.div do
        txHeaderView lang $ mkTxHeaderViewProps tx
        txBodyView lang $ mkTxBodyViewProps tx

module Explorer.View.Block (blockView) where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), isJust)

import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cBlock, blSlotNotFound, common, cBack2Dashboard, cOf, cLoading, cNotAvailable, block, blFees, blRoot, blNextBlock, blPrevBlock, blEstVolume, cHash, cSummary, cTotalOutput, cHashes, cSlot, cTransactions, tx, txNotFound, txEmpty) as I18nL
import Explorer.Lenses.State (_PageNumber, blockDetail, blockTxPagination, blockTxPaginationEditable, currentBlockSummary, currentBlockTxs, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CTxBriefs, PageNumber(..), State)
import Explorer.Util.Factory (mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, emptyView, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)

import Network.RemoteData (RemoteData(..), isFailure)

import Pos.Explorer.Web.ClientTypes (CBlockEntry(..), CBlockSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CBlockEntry, _CBlockSummary, _CHash, cbeBlkHash, cbeSlot, cbeTotalSent, cbeTxNum, cbsEntry, cbsMerkleRoot, cbsNextHash, cbsPrevHash)

import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.DOM.Events (onClick) as P

import Text.Smolder.HTML (a, div, h3, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!))

blockView :: State -> P.HTML Action
blockView state =
    let lang' = state ^. lang
        blockSummary = state ^. currentBlockSummary
        blockTxs = state ^. currentBlockTxs
    in
    S.div ! S.className "explorer-block" $ do
        S.div ! S.className "explorer-block__wrapper"
              $ S.div ! S.className "explorer-block__container"  $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cBlock) lang')
                    case blockSummary of
                        NotAsked -> blockSummaryEmptyView ""
                        Loading -> blockSummaryEmptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> blockSummaryEmptyView $ translate (I18nL.block <<< I18nL.blSlotNotFound) lang'
                        Success block -> blockSummaryView block lang'
        S.div ! S.className "explorer-block__wrapper" $ do
            S.div ! S.className "explorer-block__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang')
                case blockTxs of
                    NotAsked -> txEmptyContentView ""
                    Loading -> txEmptyContentView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> txEmptyContentView $ translate (I18nL.tx <<< I18nL.txNotFound) lang'
                    Success txs -> blockTxsView txs state
            if (isFailure blockSummary && isFailure blockTxs)
                -- Show back button if both results ^ are failed
                then
                    S.div ! S.className "explorer-block__container"
                          $ S.a ! S.href (toUrl Dashboard)
                                #! P.onClick (Navigate $ toUrl Dashboard)
                                ! S.className "btn-back"
                                $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang')
                else
                    emptyView

--  summary

type SummaryRowItem =
    { id :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CBlockEntry -> SummaryItems
mkSummaryItems lang (CBlockEntry entry) =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , amount: show $ entry ^. cbeTxNum
      , mCurrency: Nothing
      }
    , { id: "1"
      , label: translate (I18nL.common <<< I18nL.cTotalOutput) lang
      , amount: formatADA (entry ^. cbeTotalSent) lang
      , mCurrency: Just ADA
      }
    , { id: "2"
      , label: translate (I18nL.block <<< I18nL.blEstVolume) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { id: "3"
      , label: translate (I18nL.block <<< I18nL.blFees) lang
      -- TODO: We do need real data here
      , amount: formatADA (mkCoin "0") lang
      , mCurrency: Just ADA
      }
    , { id: "4"
      , label: translate (I18nL.common <<< I18nL.cSlot) lang
      , amount: show $ entry ^. cbeSlot
      , mCurrency: Nothing
      }
    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div ! S.className "row row__summary"
          ! P.key item.id
          $ do
          S.div ! S.className "column column__label"
                $ S.text item.label
          S.div ! S.className "column column__amount"
                $ if isJust item.mCurrency
                      then S.span ! S.className (currencyCSSClass item.mCurrency)
                                  $ S.text item.amount
                      else S.text item.amount

blockSummaryEmptyView :: String -> P.HTML Action
blockSummaryEmptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

blockSummaryView :: CBlockSummary -> Language -> P.HTML Action
blockSummaryView block lang =
    S.div ! S.className "blocks-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkSummaryItems lang $ block ^. (_CBlockSummary <<< cbsEntry)) summaryRow
        S.div ! S.className "hashes-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cHashes) lang)
            S.div $ for_ (mkHashItems lang block) hashesRow

-- hashes

type HashItems = Array HashRowItem

type HashRowItem =
    { id :: String
    , label :: String
    , hash :: String
    , link :: Maybe String
    }

mkHashItems :: Language -> CBlockSummary -> HashItems
mkHashItems lang (CBlockSummary blockSummery) =
    [ { id: "0"
      , label: translate (I18nL.common <<< I18nL.cHash) lang
      , hash: blockSummery ^. (cbsEntry <<< _CBlockEntry <<< cbeBlkHash <<< _CHash)
      , link: Nothing
      }
    , { id: "1"
      , label: translate (I18nL.block <<< I18nL.blPrevBlock) lang
      , hash: blockSummery ^. (cbsPrevHash <<< _CHash)
      , link: Just <<< toUrl <<< Block $ blockSummery ^. cbsPrevHash
      }
    , { id: "2"
      , label: translate (I18nL.block <<< I18nL.blNextBlock) lang
      , hash: case blockSummery ^. cbsNextHash of
          Nothing -> translate (I18nL.common <<< I18nL.cNotAvailable) lang
          Just hash -> hash ^. _CHash
      , link: case blockSummery ^. cbsNextHash of
          Nothing -> Nothing
          Just hash -> Just <<< toUrl $ Block hash
      }
    , { id: "3"
      , label: translate (I18nL.block <<< I18nL.blRoot) lang
      , hash: blockSummery ^. (cbsMerkleRoot <<< _CHash)
      , link: Nothing
      }
    ]

hashesRow :: HashRowItem -> P.HTML Action
hashesRow item =
    S.div ! S.className "row row__hashes"
          ! P.key item.id
          $ do
          S.div ! S.className "column column__label"
                $ S.text item.label
          case item.link of
              Nothing ->  S.div ! S.className "column column__hash"
                                $ S.text item.hash
              Just link -> S.a  ! S.href link
                                #! P.onClick (Navigate link)
                                ! S.className "column column__hash--link"
                                $ S.text item.hash

maxTxRows :: Int
maxTxRows = 5

blockTxsView :: CTxBriefs -> State -> P.HTML Action
blockTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
        let txPagination = state ^. (viewStates <<< blockDetail <<< blockTxPagination <<< _PageNumber)
            lang' = state ^. lang
            minTxIndex = (txPagination - minPagination) * maxTxRows
            currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
        in
        S.div do
            S.div $ for_ currentTxs (\tx -> blockTxView tx lang')
            txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                              , currentPage: PageNumber txPagination
                              , minPage: PageNumber minPagination
                              , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                              , changePageAction: BlockPaginateTxs
                              , editable: state ^. (viewStates <<< blockDetail <<< blockTxPaginationEditable)
                              , editableAction: BlockEditTxsPageNumber
                              , invalidPageAction: BlockInvalidTxsPageNumber
                              , disabled: false
                              }

blockTxView :: CTxBrief -> Language -> P.HTML Action
blockTxView tx lang =
    S.div do
        txHeaderView lang $ mkTxHeaderViewProps tx
        txBodyView lang $ mkTxBodyViewProps tx


Ensure foldl is tail-recursive

Ensure foldl is tail-recursive

module Data.CList
  ( CList(..)
  , empty
  , null
  , append
  , cons
  , snoc
  , uncons
  ) where

import Prelude (Show, (++), show)

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import qualified Data.DList as D
import qualified Data.List as L

data CList a = CNil | CCons a (D.DList (CList a))

empty :: forall a. CList a
empty = CNil

null :: forall a. CList a -> Boolean
null CNil = true
null _ = false

append :: forall a. CList a -> CList a -> CList a
append as CNil = as
append CNil as = as
append as bs = link as bs

cons :: forall a. a -> CList a -> CList a
cons a clist = append (CCons a D.empty) clist

snoc :: forall a. CList a -> a -> CList a
snoc clist a = append clist (CCons a D.empty)

uncons :: forall a. CList a -> Maybe (Tuple a (CList a))
uncons CNil = Nothing
uncons (CCons a dlist) = Just (Tuple a (if D.null dlist
                                           then CNil
                                           else linkAll dlist))

link :: forall a. CList a -> CList a -> CList a
link CNil clist = clist
link (CCons a dlist) clist = CCons a (D.snoc dlist clist)

linkAll :: forall a. D.DList (CList a) -> CList a
linkAll dlist = foldr link CNil dlist

foldr :: forall a. (CList a -> CList a -> CList a) -> CList a -> D.DList (CList a) -> CList a
foldr k = foldr' (\a -> Left (\b -> k a b))

foldr' :: forall a. (CList a -> Either (CList a -> CList a) (CList a)) -> CList a -> D.DList (CList a) -> CList a
foldr' k b dlist = go dlist L.Nil
  where
  unroll :: CList a -> L.List (CList a -> CList a) -> CList a
  unroll = foldl (\x i -> i x)

  foldl :: forall a b. (b -> a -> b) -> b -> L.List a -> b
  foldl _ b L.Nil = b
  foldl k b (L.Cons a as) = foldl k (k b a) as

  go :: D.DList (CList a) -> L.List (CList a -> CList a) -> CList a
  go xs ys = case D.uncons xs of
                  Nothing -> unroll b ys
                  Just (Tuple a rest) ->
                    case k a of
                         Right b' -> unroll b' ys
                         Left j -> go rest (L.Cons j ys)

instance showCList :: (Show a) => Show (CList a) where
  show CNil = "CNil"
  show (CCons a as) = "CList (" ++ show a ++ ") (" ++ show as ++ ")"

module Data.CList
  ( CList(..)
  , empty
  , null
  , append
  , cons
  , snoc
  , uncons
  ) where

import Prelude (Show, (++), show)

import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import qualified Data.DList as D
import qualified Data.List as L

data CList a = CNil | CCons a (D.DList (CList a))

empty :: forall a. CList a
empty = CNil

null :: forall a. CList a -> Boolean
null CNil = true
null _ = false

append :: forall a. CList a -> CList a -> CList a
append as CNil = as
append CNil as = as
append as bs = link as bs

cons :: forall a. a -> CList a -> CList a
cons a clist = append (CCons a D.empty) clist

snoc :: forall a. CList a -> a -> CList a
snoc clist a = append clist (CCons a D.empty)

uncons :: forall a. CList a -> Maybe (Tuple a (CList a))
uncons CNil = Nothing
uncons (CCons a dlist) = Just (Tuple a (if D.null dlist
                                           then CNil
                                           else linkAll dlist))

link :: forall a. CList a -> CList a -> CList a
link CNil clist = clist
link (CCons a dlist) clist = CCons a (D.snoc dlist clist)

linkAll :: forall a. D.DList (CList a) -> CList a
linkAll dlist = foldr link CNil dlist

foldr :: forall a. (CList a -> CList a -> CList a) -> CList a -> D.DList (CList a) -> CList a
foldr k = foldr' (\a -> Left (\b -> k a b))

foldr' :: forall a. (CList a -> Either (CList a -> CList a) (CList a)) -> CList a -> D.DList (CList a) -> CList a
foldr' k b dlist = go dlist L.Nil
  where
  unroll :: CList a -> L.List (CList a -> CList a) -> CList a
  unroll = foldl (\x i -> i x)

  go :: D.DList (CList a) -> L.List (CList a -> CList a) -> CList a
  go xs ys = case D.uncons xs of
                  Nothing -> unroll b ys
                  Just (Tuple a rest) ->
                    case k a of
                         Right b' -> unroll b' ys
                         Left j -> go rest (L.Cons j ys)

instance showCList :: (Show a) => Show (CList a) where
  show CNil = "CNil"
  show (CCons a as) = "CList (" ++ show a ++ ") (" ++ show as ++ ")"