Break lines consistently

Break lines consistently

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat)
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Foldable (foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)
import Data.Map (Map())
import qualified Data.Map as Map

import qualified Text.Parsing.Parser             as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos         as P
import qualified Text.Parsing.Parser.String      as P

import qualified Language.Docopt.Errors   as D
import qualified Language.Docopt.Value    as D
import qualified Language.Docopt.Argument as D
import qualified Language.Docopt.Usage    as D
import qualified Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.Parser (List Token) a

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: D.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (takesArg == false) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a
    def      = maybe Nothing (\(O.Argument _ v) -> v) a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs Nothing) _ | (f' == f) && takesArg && (A.length xs > 0)
      = return $ OptParse (D.StringValue $ fromCharArray xs)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (takesArg == false) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (takesArg == false) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = do
  P.choice $ xs <#> \x -> Tuple x <$> genBranchParser x
  <* eof

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (List (Tuple D.Argument D.Value))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- genExhaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                       -> Parser (List (Tuple D.Argument D.Value))
    genExhaustiveParser Nil = pure empty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument
             -> Int
             -> Parser (List (Tuple D.Argument D.Value))
        draw pss@(Cons p ps') n | n >= 0 = (do
          xs <- genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a switch, an explicit argument *must* be provided.
          let ys = map (\(Tuple a _) -> a) $
                    filter
                      (\(Tuple a v) -> (D.takesArgument a)
                                    && (not $ D.isFlag a)
                                    && (D.isBoolValue v))
                      xs
          if (length ys > 0)
            then P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)
            else return unit

          xss <- if D.isRepeatable p
                      then draw pss (length pss)
                      else draw (ps') (length ps')
          return $ xs ++ xss
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))
        draw ps' n | (length ps' > 0) && (n < 0) = do
          let rest = filter
                      (\p -> (not $ D.isRepeatable p)
                          && (not $ D.hasDefault p))
                      (reverse ps')
          if (length rest > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> rest)
            else return empty
        draw _ _ = return empty

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _ _ _ _)
      = Right $ Pending p (singleton x)
    step (Free p) x@(D.Group _ bs _) | isFree x
      = Right $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- genParser x
      return $ a ++ as

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _ _ _ _) = Right $
      Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a   <- p
        as  <- genExhaustiveParser xs
        ass <- genParser y
        return (a ++ as ++ ass)

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -> Parser (List (Tuple D.Argument D.Value))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
      where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option f n a r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser n a)
          , Tuple x <$> (mkSoptParser f a)
          ]

        mkLoptParser (Just n) a = longOption n a
        mkLoptParser Nothing _  = P.fail "no long name"

        mkSoptParser (Just f) a = shortOption f a
        mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for a argument `Group`
    genParser x@(D.Group optional bs repeated) = do
      concat <$>
        let mod    = if optional then P.option empty else \p -> p
            parser = if repeated then many go else singleton <$> go
         in mod parser
      where go = if length bs > 0
                    then P.choice $ P.try <<< genBranchParser <$> bs
                    else return empty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _ _ _ _) = true
    isFree (D.Group _ bs _)   = all (\(D.Branch b) -> all isFree b) bs
    isFree _                  = false


[CSE-87] Fix duration

[CSE-87] Fix duration

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    , unwrapLatestBlocks
    ) where

import Prelude
import Control.Monad.Eff.Exception (Error)
import Data.Array (length, null, slice)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.DateTime (diff)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.NominalDiffTime.Lenses (_NominalDiffTime)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cRelayedBy, cSizeKB) as I18nL
import Explorer.Lenses.State (blocksViewState, blsViewPagination, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State, CBlockEntries)
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnRelayedBy, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (getMaxPaginationNumber, noData, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CCoin, getCoin)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeEpoch, cbeSlot, cbeRelayedBy, cbeSize, cbeTimeIssued, cbeTotalSent, cbeTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML) as P
import Pux.Router (link) as P

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.Html Action
blocksView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-blocks" ]
        [ P.div
            [ P.className "explorer-blocks__wrapper" ]
            [ P.div
                [ P.className "explorer-blocks__container" ]
                [ P.h3
                      [ P.className "headline" ]
                      [ P.text $
                            (translate (I18nL.common <<< I18nL.cEpoch) lang')
                            <> " / " <>
                            (translate (I18nL.common <<< I18nL.cSlot) lang')
                      ]
                , case state ^. currentBlocksResult of
                      NotAsked  -> emptyBlocksView ""
                      Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> failureView lang'
                      Success blocks ->
                          let paginationViewProps =
                                  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                  , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                  , maxPage: getMaxPaginationNumber (length blocks) maxBlockRows
                                  , changePageAction: BlocksPaginateBlocks
                                  , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                  }
                          in
                          P.div
                              []
                              [ blocksHeaderView blocks lang'
                              , P.div
                                  [ P.className CSS.blocksBody ]
                                  $ map (blockRow state) (currentBlocks state)
                              , P.div
                                  [ P.className CSS.blocksFooter ]
                                  [ paginationView paginationViewProps ]
                              ]
                  ]
            ]
        ]

emptyBlocksView :: String -> P.Html Action
emptyBlocksView message =
    P.div
        [ P.className "blocks-message"
        , P.dangerouslySetInnerHTML message ]
        []

failureView :: Language -> P.Html Action
failureView lang =
    P.div
        []
        [ P.p
            [ P.className CSS.blocksFailed ]
            [ P.text $ translate (I18nL.block <<< I18nL.blNotFound) lang ]
        , P.link (toUrl Dashboard)
            [ P.className "btn-back" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang ]
        ]

unwrapLatestBlocks :: RemoteData Error CBlockEntries -> CBlockEntries
unwrapLatestBlocks blocks =
    case blocks of
            Success blocks' -> blocks'
            _ -> []

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = unwrapLatestBlocks $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className CSS.blocksBodyRow ]
        [ blockColumn { label: show $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      }
        , blockColumn { label: show $ entry ^. cbeSlot
                      , clazz: CSS.blocksColumnSlot
                      }
        , blockColumn { label: labelAge
                      , clazz: CSS.blocksColumnAge
                      }
        , blockColumn { label: show $ entry ^. cbeTxNum
                      , clazz: CSS.blocksColumnTxs
                      }
        , blockColumn { label: entry ^. (cbeTotalSent <<< _CCoin <<< getCoin)
                      , clazz: CSS.blocksColumnTotalSent
                      }
        , blockColumn { label: labelRelayed
                      , clazz: CSS.blocksColumnRelayedBy
                      }
        , blockColumn { label: show $ entry ^. cbeSize
                      , clazz: CSS.blocksColumnSize
                      }
        ]
    where
        language = state ^. lang
        labelAge = fromMaybe noData $ (prettyDuration language :: Milliseconds -> String) <<< diff state.now <$> (nominalDiffTimeToDateTime  =<< entry.cbeTimeIssued)
        labelRelayed = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ entry ^. cbeRelayedBy

type BlockColumnProps =
    { label :: String
    , clazz :: String
    }

blockColumn :: BlockColumnProps -> P.Html Action
blockColumn props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

type BlocksHeaderProps =
    { label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    , { label: translate (I18nL.common <<< I18nL.cAge) lang
      , clazz: CSS.blocksColumnAge
      }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
    , { label: translate (I18nL.common <<< I18nL.cRelayedBy) lang
      , clazz: CSS.blocksColumnRelayedBy
      }
    , { label: translate (I18nL.common <<< I18nL.cSizeKB) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.Html Action
blocksHeaderView blocks lang =
    P.div
          [ P.className $ CSS.blocksHeader
                <>  if null blocks then " hide" else ""
          ]
          <<< map blockHeaderItemView $ mkBlocksHeaderProps lang

blockHeaderItemView :: BlocksHeaderProps -> P.Html Action
blockHeaderItemView props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    , unwrapLatestBlocks
    ) where

import Prelude
import Control.Monad.Eff.Exception (Error)
import Data.Array (length, null, slice)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.NominalDiffTime.Lenses (_NominalDiffTime)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cRelayedBy, cSizeKB) as I18nL
import Explorer.Lenses.State (blocksViewState, blsViewPagination, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State, CBlockEntries)
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.Time (prettyDuration)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnRelayedBy, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (getMaxPaginationNumber, noData, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CCoin, getCoin)
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (cbeBlkHash, cbeEpoch, cbeSlot, cbeRelayedBy, cbeSize, cbeTimeIssued, cbeTotalSent, cbeTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML) as P
import Pux.Router (link) as P

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.Html Action
blocksView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-blocks" ]
        [ P.div
            [ P.className "explorer-blocks__wrapper" ]
            [ P.div
                [ P.className "explorer-blocks__container" ]
                [ P.h3
                      [ P.className "headline" ]
                      [ P.text $
                            (translate (I18nL.common <<< I18nL.cEpoch) lang')
                            <> " / " <>
                            (translate (I18nL.common <<< I18nL.cSlot) lang')
                      ]
                , case state ^. currentBlocksResult of
                      NotAsked  -> emptyBlocksView ""
                      Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> failureView lang'
                      Success blocks ->
                          let paginationViewProps =
                                  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                  , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                  , maxPage: getMaxPaginationNumber (length blocks) maxBlockRows
                                  , changePageAction: BlocksPaginateBlocks
                                  , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                  }
                          in
                          P.div
                              []
                              [ blocksHeaderView blocks lang'
                              , P.div
                                  [ P.className CSS.blocksBody ]
                                  $ map (blockRow state) (currentBlocks state)
                              , P.div
                                  [ P.className CSS.blocksFooter ]
                                  [ paginationView paginationViewProps ]
                              ]
                  ]
            ]
        ]

emptyBlocksView :: String -> P.Html Action
emptyBlocksView message =
    P.div
        [ P.className "blocks-message"
        , P.dangerouslySetInnerHTML message ]
        []

failureView :: Language -> P.Html Action
failureView lang =
    P.div
        []
        [ P.p
            [ P.className CSS.blocksFailed ]
            [ P.text $ translate (I18nL.block <<< I18nL.blNotFound) lang ]
        , P.link (toUrl Dashboard)
            [ P.className "btn-back" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang ]
        ]

unwrapLatestBlocks :: RemoteData Error CBlockEntries -> CBlockEntries
unwrapLatestBlocks blocks =
    case blocks of
            Success blocks' -> blocks'
            _ -> []

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = unwrapLatestBlocks $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className CSS.blocksBodyRow ]
        [ blockColumn { label: show $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      }
        , blockColumn { label: show $ entry ^. cbeSlot
                      , clazz: CSS.blocksColumnSlot
                      }
        , blockColumn { label: labelAge
                      , clazz: CSS.blocksColumnAge
                      }
        , blockColumn { label: show $ entry ^. cbeTxNum
                      , clazz: CSS.blocksColumnTxs
                      }
        , blockColumn { label: entry ^. (cbeTotalSent <<< _CCoin <<< getCoin)
                      , clazz: CSS.blocksColumnTotalSent
                      }
        , blockColumn { label: labelRelayed
                      , clazz: CSS.blocksColumnRelayedBy
                      }
        , blockColumn { label: show $ entry ^. cbeSize
                      , clazz: CSS.blocksColumnSize
                      }
        ]
    where
        language = state ^. lang
        labelAge = case entry ^. cbeTimeIssued of
                        Just time -> prettyDuration language (Milliseconds
                            <<< unwrap $ time ^. _NominalDiffTime)
                        Nothing -> noData
        labelRelayed = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ entry ^. cbeRelayedBy

type BlockColumnProps =
    { label :: String
    , clazz :: String
    }

blockColumn :: BlockColumnProps -> P.Html Action
blockColumn props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

type BlocksHeaderProps =
    { label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    , { label: translate (I18nL.common <<< I18nL.cAge) lang
      , clazz: CSS.blocksColumnAge
      }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
    , { label: translate (I18nL.common <<< I18nL.cRelayedBy) lang
      , clazz: CSS.blocksColumnRelayedBy
      }
    , { label: translate (I18nL.common <<< I18nL.cSizeKB) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.Html Action
blocksHeaderView blocks lang =
    P.div
          [ P.className $ CSS.blocksHeader
                <>  if null blocks then " hide" else ""
          ]
          <<< map blockHeaderItemView $ mkBlocksHeaderProps lang

blockHeaderItemView :: BlocksHeaderProps -> P.Html Action
blockHeaderItemView props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]


Change hardcoded testing example *rolls eyes*

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM

import Data.Either

import Web
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  print "Hello world!"
  let expr = case parseExpr "1 : (1 + 2) : [3 * 4, 9 `div` 3]" of Right e -> e
  let env = defsToEnv $ case parseDefs "double x = x + x" of Right d -> d
  showExpr expr
  return unit

showExpr :: forall eff. Expr -> Eff (dom :: DOM | eff) Unit
showExpr expr = do
  test <- J.select "#test"
  J.clear test
  jexpr <- exprToJQuery expr showExpr
  J.append jexpr test
  return unit

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM

import Data.Either

import Web
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  print "Hello world!"
  let expr = case parseExpr "1 + 2 * 3 + 4 * 5 * 6" of Right e -> e
  let env = defsToEnv $ case parseDefs "double x = x + x" of Right d -> d
  showExpr expr
  return unit

showExpr :: forall eff. Expr -> Eff (dom :: DOM | eff) Unit
showExpr expr = do
  test <- J.select "#test"
  J.clear test
  jexpr <- exprToJQuery expr showExpr
  J.append jexpr test
  return unit


use flipply to makeTransition on bound chart1

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

fub :: forall d eff. Eff (d3::D3|eff) (Transition d)
fub = d3Transition "erg"
        .. duration 750.0

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

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do

  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

  chart2 ... makeTransition

  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

fub :: forall d eff. Eff (d3::D3|eff) (Transition d)
fub = d3Transition "erg"
        .. duration 750.0

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

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do

  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

  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

  pure unit


Simplify renderForUI with a dedicated function to attempt both JSON interpretations

Original commit 93b02cc91072ce717b70587aceedcd42951f0a5f

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Doc.Renderer -> Json -> String
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer

tryRenderFromJsonSchema :: Doc.Renderer -> Json -> Either Error String
tryRenderFromJsonSchema renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

-- Try to render from Json as Schema, falling back on simply rendering from Json
renderFromSchemaOrJson :: Doc.Renderer -> Json -> String
renderFromSchemaOrJson renderer json =
    case tryRenderFromJsonSchema renderer json of
        Left err -> renderFromJson renderer json
        Right src -> src

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = renderFromSchemaOrJson renderer <$> J.jsonParser json

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp

import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J

import Data.Array as A
import Data.Either (Either(..), either)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Doc.Renderer -> Json -> String
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer

tryRenderFromJsonSchema :: Doc.Renderer -> Json -> Either Error String
tryRenderFromJsonSchema renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json =
    J.jsonParser json
    >>= (\j ->
        tryRenderFromJsonSchema renderer j
        # either (\_ -> Right $ renderFromJson renderer j) Right)


Add some comments

Add some comments

module DOM where

-- | Effect type for DOM maniupulation
foreign import data DOM :: !

-- | General type for DOM nodes.
foreign import data Node :: *

-- | General type for DOM node lists.
foreign import data NodeList :: *

module DOM where

  foreign import data Node :: *

  foreign import data NodeList :: *

  foreign import data DOM :: !


Added Foldable assertion tests.

Added Foldable assertion tests.

module Test.Spec.AssertionSpec where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldContain, shouldNotContain) as A
import Test.Spec.Assertions.Aff (expectError) as AF
import Test.Spec.Assertions.String (shouldContain, shouldNotContain) as AS
import Test.Spec.Runner (RunnerEffects)

assertionSpec :: ∀ e. Spec (RunnerEffects e) Unit
assertionSpec =
  describe "Test" $
    describe "Spec" $
      describe "Assertions" do

        describe "String" do
          describe "shouldContain" do
            it "accepts strings that contains substrings" $
              "foobar" `AS.shouldContain` "foo"
            it "rejects strings that does not contain substrings" $
              AF.expectError $ "baz" `AS.shouldContain` "foo"

          describe "shouldNotContain" do
            it "accepts strings that does not contain substrings" $
              "foobar" `AS.shouldNotContain` "baz"
            it "rejects strings that contains substrings" $
              AF.expectError $ "bazbar" `AS.shouldNotContain` "baz"

        describe "Foldable" do
          describe "for some foldable" do
            let f = ["haha", "nono"]
            let contained = "nono"
            let notcontained = "zzz"

            describe "shouldContain" do
              it "accepts f that contains a" $
                f `A.shouldContain` contained
              it "rejects f that does not contain a" $
                AF.expectError $ f `A.shouldContain` notcontained

            describe "shouldNotContain" do
              it "accepts f that does not contain a" $
                f `A.shouldNotContain` notcontained
              it "rejects f that contains a" $
                AF.expectError $ f `A.shouldNotContain` contained

        describe "Aff" $
          describe "expectError" do
            it "returns unit when given an error" $
              AF.expectError $ throwError $ error "omg"
            it "returns an error when given a non-error" $
              AF.expectError $ AF.expectError $ pure "ok"

module Test.Spec.AssertionSpec where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions.Aff (expectError) as AF
import Test.Spec.Assertions.String (shouldContain, shouldNotContain) as AS
import Test.Spec.Runner (RunnerEffects)

assertionSpec :: ∀ e. Spec (RunnerEffects e) Unit
assertionSpec =
  describe "Test" $
    describe "Spec" $
      describe "Assertions" do

        describe "String" do
          describe "shouldContain" do
            it "accepts strings that contains substrings" $
              "foobar" `AS.shouldContain` "foo"
            it "rejects strings that does not contain substrings" $
              AF.expectError $ "baz" `AS.shouldContain` "foo"

          describe "shouldNotContain" do
            it "accepts strings that does not contain substrings" $
              "foobar" `AS.shouldNotContain` "baz"
            it "rejects strings that contains substrings" $
              AF.expectError $ "bazbar" `AS.shouldNotContain` "baz"

        describe "Aff" $
          describe "expectError" do
            it "returns unit when given an error" $
              AF.expectError $ throwError $ error "omg"
            it "returns an error when given a non-error" $
              AF.expectError $ AF.expectError $ pure "ok"


Add type & functions for mapping clicks to Glyphs

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

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

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 30.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

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

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

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

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

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs gs p = filter pred gs
  where pred = \g -> unwrap (glyphBounds g) p
browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w} <- liftEff $ getScreenSize
  h <- liftEff $ getCanvasHeight canvas
  _ <- liftEff $ setCanvasWidth (w-2.0) canvas
  backCanvas <- liftEff $ newCanvas {w,h}

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      -- f = fetchWithView 100

  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 = viewBehavior 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
    -- fetch & draw
    clearCanvas canvas
    _ <- launchAff $ fetchToCanvas h f v' ctx
    -- update other UI elements
    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap)
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

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

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 30.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

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

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

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

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

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

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

  {w} <- liftEff $ getScreenSize
  h <- liftEff $ getCanvasHeight canvas
  _ <- liftEff $ setCanvasWidth (w-2.0) canvas
  backCanvas <- liftEff $ newCanvas {w,h}

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      -- f = fetchWithView 100

  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 = viewBehavior 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
    -- fetch & draw
    clearCanvas canvas
    _ <- launchAff $ fetchToCanvas f v' ctx
    -- update other UI elements
    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser


[CSE-98] Fix currencyCSS

[CSE-98] Fix currencyCSS

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    , unwrapLatestBlocks
    ) where

import Prelude
import Control.Monad.Eff.Exception (Error)
import Data.Array (length, null, slice)
import Data.Lens ((^.))
import Data.Maybe (fromMaybe)
import Data.DateTime (diff)
import Data.Time.Duration (Milliseconds)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cRelayedBy, cSizeKB) as I18nL
import Explorer.Lenses.State (blocksViewState, blsViewPagination, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State, CBlockEntries, CCurrency (ADA))
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnRelayedBy, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (getMaxPaginationNumber, noData, paginationView, currencyCSSClass)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CCoin, getCoin, cbeBlkHash, cbeEpoch, cbeSlot, cbeRelayedBy, cbeSize, cbeTotalSent, cbeTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML) as P
import Pux.Router (link) as P

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.Html Action
blocksView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-blocks" ]
        [ P.div
            [ P.className "explorer-blocks__wrapper" ]
            [ P.div
                [ P.className "explorer-blocks__container" ]
                [ P.h3
                      [ P.className "headline" ]
                      [ P.text $
                            (translate (I18nL.common <<< I18nL.cEpoch) lang')
                            <> " / " <>
                            (translate (I18nL.common <<< I18nL.cSlot) lang')
                      ]
                , case state ^. currentBlocksResult of
                      NotAsked  -> emptyBlocksView ""
                      Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> failureView lang'
                      Success blocks ->
                          let paginationViewProps =
                                  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                  , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                  , maxPage: getMaxPaginationNumber (length blocks) maxBlockRows
                                  , changePageAction: BlocksPaginateBlocks
                                  , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                  }
                          in
                          P.div
                              []
                              [ blocksHeaderView blocks lang'
                              , P.div
                                  [ P.className CSS.blocksBody ]
                                  $ map (blockRow state) (currentBlocks state)
                              , P.div
                                  [ P.className CSS.blocksFooter ]
                                  [ paginationView paginationViewProps ]
                              ]
                  ]
            ]
        ]

emptyBlocksView :: String -> P.Html Action
emptyBlocksView message =
    P.div
        [ P.className "blocks-message"
        , P.dangerouslySetInnerHTML message ]
        []

failureView :: Language -> P.Html Action
failureView lang =
    P.div
        []
        [ P.p
            [ P.className CSS.blocksFailed ]
            [ P.text $ translate (I18nL.block <<< I18nL.blNotFound) lang ]
        , P.link (toUrl Dashboard)
            [ P.className "btn-back" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang ]
        ]

unwrapLatestBlocks :: RemoteData Error CBlockEntries -> CBlockEntries
unwrapLatestBlocks blocks =
    case blocks of
            Success blocks' -> blocks'
            _ -> []

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = unwrapLatestBlocks $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className CSS.blocksBodyRow ]
        [ blockColumn { label: show $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      }
        , blockColumn { label: show $ entry ^. cbeSlot
                      , clazz: CSS.blocksColumnSlot
                      }
        , blockColumn { label: labelAge
                      , clazz: CSS.blocksColumnAge
                      }
        , blockColumn { label: show $ entry ^. cbeTxNum
                      , clazz: CSS.blocksColumnTxs
                      }
        , blockColumn { label: entry ^. (cbeTotalSent <<< _CCoin <<< getCoin)
                      , clazz: CSS.blocksColumnTotalSent
                      }
--        , blockColumn { label: labelRelayed
--                      , clazz: CSS.blocksColumnRelayedBy
--                      }
        , blockColumn { label: show $ entry ^. cbeSize
                      , clazz: CSS.blocksColumnSize
                      }
        ]
    where
        language = state ^. lang
        labelAge = fromMaybe noData $ (prettyDuration language :: Milliseconds -> String) <<< diff state.now <$> (nominalDiffTimeToDateTime  =<< entry.cbeTimeIssued)
        labelRelayed = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ entry ^. cbeRelayedBy

type BlockColumnProps =
    { label :: String
    , clazz :: String
    }

blockColumn :: BlockColumnProps -> P.Html Action
blockColumn props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

type BlocksHeaderProps =
    { label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    , { label: translate (I18nL.common <<< I18nL.cAge) lang
      , clazz: CSS.blocksColumnAge
      }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
--    , { label: translate (I18nL.common <<< I18nL.cRelayedBy) lang
--      , clazz: CSS.blocksColumnRelayedBy
--      }
    , { label: translate (I18nL.common <<< I18nL.cSizeKB) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.Html Action
blocksHeaderView blocks lang =
    P.div
          [ P.className $ CSS.blocksHeader
                <>  if null blocks then " hide" else ""
          ]
          <<< map blockHeaderItemView $ mkBlocksHeaderProps lang

blockHeaderItemView :: BlocksHeaderProps -> P.Html Action
blockHeaderItemView props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

module Explorer.View.Blocks
    ( blocksView
    , blockRow
    , blocksHeaderView
    , blockHeaderItemView
    , maxBlockRows
    , minBlockRows
    , unwrapLatestBlocks
    ) where

import Prelude
import Control.Monad.Eff.Exception (Error)
import Data.Array (length, null, slice)
import Data.Lens ((^.))
import Data.Maybe (fromMaybe)
import Data.DateTime (diff)
import Data.Time.Duration (Milliseconds)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (block, blNotFound, cBack2Dashboard, cLoading, cOf, common, cUnknown, cEpoch, cSlot, cAge, cTransactions, cTotalSent, cRelayedBy, cSizeKB) as I18nL
import Explorer.Lenses.State (blocksViewState, blsViewPagination, currentBlocksResult, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (State, CBlockEntries, CCurrency (ADA))
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime)
import Explorer.View.CSS (blocksBody, blocksBodyRow, blocksColumnAge, blocksColumnEpoch, blocksColumnRelayedBy, blocksColumnSize, blocksColumnSlot, blocksColumnTotalSent, blocksColumnTxs, blocksFailed, blocksFooter, blocksHeader) as CSS
import Explorer.View.Common (getMaxPaginationNumber, noData, paginationView, currencyCSSClass)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CBlockEntry(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CCoin, getCoin, cbeBlkHash, cbeEpoch, cbeSlot, cbeRelayedBy, cbeSize, cbeTotalSent, cbeTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML) as P
import Pux.Router (link) as P

maxBlockRows :: Int
maxBlockRows = 10

minBlockRows :: Int
minBlockRows = 3

blocksView :: State -> P.Html Action
blocksView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-blocks" ]
        [ P.div
            [ P.className "explorer-blocks__wrapper" ]
            [ P.div
                [ P.className "explorer-blocks__container" ]
                [ P.h3
                      [ P.className "headline" ]
                      [ P.text $
                            (translate (I18nL.common <<< I18nL.cEpoch) lang')
                            <> " / " <>
                            (translate (I18nL.common <<< I18nL.cSlot) lang')
                      ]
                , case state ^. currentBlocksResult of
                      NotAsked  -> emptyBlocksView ""
                      Loading   -> emptyBlocksView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                      Failure _ -> failureView lang'
                      Success blocks ->
                          let paginationViewProps =
                                  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                  , currentPage: state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
                                  , maxPage: getMaxPaginationNumber (length blocks) maxBlockRows
                                  , changePageAction: BlocksPaginateBlocks
                                  , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                  }
                          in
                          P.div
                              []
                              [ blocksHeaderView blocks lang'
                              , P.div
                                  [ P.className CSS.blocksBody ]
                                  $ map (blockRow state) (currentBlocks state)
                              , P.div
                                  [ P.className CSS.blocksFooter ]
                                  [ paginationView paginationViewProps ]
                              ]
                  ]
            ]
        ]

emptyBlocksView :: String -> P.Html Action
emptyBlocksView message =
    P.div
        [ P.className "blocks-message"
        , P.dangerouslySetInnerHTML message ]
        []

failureView :: Language -> P.Html Action
failureView lang =
    P.div
        []
        [ P.p
            [ P.className CSS.blocksFailed ]
            [ P.text $ translate (I18nL.block <<< I18nL.blNotFound) lang ]
        , P.link (toUrl Dashboard)
            [ P.className "btn-back" ]
            [ P.text $ translate (I18nL.common <<< I18nL.cBack2Dashboard) lang ]
        ]

unwrapLatestBlocks :: RemoteData Error CBlockEntries -> CBlockEntries
unwrapLatestBlocks blocks =
    case blocks of
            Success blocks' -> blocks'
            _ -> []

currentBlocks :: State -> CBlockEntries
currentBlocks state =
    slice minBlockIndex (minBlockIndex + maxBlockRows) blocks
    where
        blocks = unwrapLatestBlocks $ state ^. currentBlocksResult
        currentBlockPage = state ^. (viewStates <<< blocksViewState <<< blsViewPagination)
        minBlockIndex = (currentBlockPage - 1) * maxBlockRows

blockRow :: State -> CBlockEntry -> P.Html Action
blockRow state (CBlockEntry entry) =
    P.link (toUrl <<< Block $ entry ^. cbeBlkHash)
        [ P.className CSS.blocksBodyRow ]
        [ blockColumn { label: show $ entry ^. cbeEpoch
                      , clazz: CSS.blocksColumnEpoch
                      }
        , blockColumn { label: show $ entry ^. cbeSlot
                      , clazz: CSS.blocksColumnSlot
                      }
        , blockColumn { label: labelAge
                      , clazz: CSS.blocksColumnAge
                      }
        , blockColumn { label: show $ entry ^. cbeTxNum
                      , clazz: CSS.blocksColumnTxs
                      }
        , blockColumn { label: entry ^. (cbeTotalSent <<< _CCoin <<< getCoin)
                      , clazz: CSS.blocksColumnTotalSent <> " " <> currencyCSSClass (pure ADA)
                      }
--        , blockColumn { label: labelRelayed
--                      , clazz: CSS.blocksColumnRelayedBy
--                      }
        , blockColumn { label: show $ entry ^. cbeSize
                      , clazz: CSS.blocksColumnSize
                      }
        ]
    where
        language = state ^. lang
        labelAge = fromMaybe noData $ (prettyDuration language :: Milliseconds -> String) <<< diff state.now <$> (nominalDiffTimeToDateTime  =<< entry.cbeTimeIssued)
        labelRelayed = fromMaybe (translate (I18nL.common <<< I18nL.cUnknown) language)
                            $ entry ^. cbeRelayedBy

type BlockColumnProps =
    { label :: String
    , clazz :: String
    }

blockColumn :: BlockColumnProps -> P.Html Action
blockColumn props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]

type BlocksHeaderProps =
    { label :: String
    , clazz :: String
    }

mkBlocksHeaderProps :: Language -> Array BlocksHeaderProps
mkBlocksHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cEpoch) lang
      , clazz: CSS.blocksColumnEpoch
      }
    , { label: translate (I18nL.common <<< I18nL.cSlot) lang
      , clazz: CSS.blocksColumnSlot
      }
    , { label: translate (I18nL.common <<< I18nL.cAge) lang
      , clazz: CSS.blocksColumnAge
      }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , clazz: CSS.blocksColumnTxs
      }
    , { label: translate (I18nL.common <<< I18nL.cTotalSent) lang
      , clazz: CSS.blocksColumnTotalSent
      }
--    , { label: translate (I18nL.common <<< I18nL.cRelayedBy) lang
--      , clazz: CSS.blocksColumnRelayedBy
--      }
    , { label: translate (I18nL.common <<< I18nL.cSizeKB) lang
      , clazz: CSS.blocksColumnSize
      }
    ]

blocksHeaderView :: CBlockEntries -> Language -> P.Html Action
blocksHeaderView blocks lang =
    P.div
          [ P.className $ CSS.blocksHeader
                <>  if null blocks then " hide" else ""
          ]
          <<< map blockHeaderItemView $ mkBlocksHeaderProps lang

blockHeaderItemView :: BlocksHeaderProps -> P.Html Action
blockHeaderItemView props =
    P.div
        [ P.className props.clazz ]
        [ P.text props.label ]


CSE-159 Enabling time ticks so we can calculate TimeDiff.

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.SocketIO.Client (connect, on)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (click)
import DOM.HTML.Location (pathname)
import DOM.HTML.Types (htmlDocumentToEventTarget)
import DOM.HTML.Window (document, location)
import Data.Lens ((^.), set)
import Data.Maybe (Maybe(..), fromMaybe)
import Explorer.Api.Socket (addressTxsUpdatedEventHandler, blocksPageUpdatedEventHandler, callYouEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, toEvent, txsUpdatedHandler) as Ex
import Explorer.I18n.Lang (Language(..), detectLocale)
import Explorer.Lenses.State (connection, testnet, lang, socket, syncAction)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..), ActionChannel) as Ex
import Explorer.Types.App (AppEffects)
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (SyncAction(..), hostname, isTestnet, isProduction, secureProtocol)
import Explorer.View.Layout (view)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, start)
import Pux.DOM.Events (DOMEvent)
import Pux.DOM.History (sampleURL)
import Pux.Renderer.React (renderToDOM)
import Signal (Signal, (~>))
import Signal.Channel (channel, send, subscribe)
import Signal.Time (every, second)

type AppConfig eff = (Config (DOMEvent -> Ex.Action) Ex.Action Ex.State (AppEffects eff))

-- | Config to synchronize data by socket-io
socketConfig :: forall eff . (AppConfig eff) -> Ex.ActionChannel -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
socketConfig appConfig actionChannel = do
    -- socket
    let pingSignal = every (10.0 * second) ~> const Ex.SocketPing
    socketHost <- Ex.mkSocketHost (secureProtocol isProduction) <$> hostname
    socket' <- connect socketHost
    _ <- on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
    _ <- on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
    _ <- on socket' (Ex.toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
    _ <- on socket' (Ex.toEvent BlocksLastPageUpdated) $ Ex.blocksPageUpdatedEventHandler actionChannel
    _ <- on socket' (Ex.toEvent AddrUpdated) $ Ex.addressTxsUpdatedEventHandler actionChannel
    -- Note:
    -- `CallYou` is the answer of `CallMe`.
    -- Handling both events are needed a to be connected with socket.io manually
    _ <- on socket' (Ex.toEvent CallYou) $ Ex.callYouEventHandler actionChannel
    pure $ appConfig
        { initialState = set (socket <<< connection) (Just socket') appConfig.initialState
        , inputs = [ pingSignal ] <> appConfig.inputs
        }

-- | Config to synchronize data by polling
pollingConfig :: forall eff . (AppConfig eff) -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
pollingConfig appConfig =
    let reloadSignal = every (60.0 * second) ~> const Ex.Reload in
    pure $ appConfig
        { inputs = [ reloadSignal ] <> appConfig.inputs
        }

-- | Common config
commonConfig :: forall eff . Ex.State -> Ex.ActionChannel -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
commonConfig state actionChannel = do
    -- routing
    urlSignal <- sampleURL =<< window
    let routeSignal = urlSignal ~> (Ex.UpdateView <<< match)
    -- timer
    let clockSignal = every second ~> const Ex.UpdateClock
    -- detected locale
    locale <- fromMaybe English <$> detectLocale
    -- register actionSignal
    let actionSignal = subscribe actionChannel :: Signal Ex.Action
    -- register global (document) click listener
    -- globalClickListener :: forall eff. Event -> Eff (channel :: CHANNEL | eff) Unit
    let globalClickListener event = send actionChannel $ Ex.DocumentClicked event

    _ <- window >>=
            document >>=
                htmlDocumentToEventTarget >>>
                    addEventListener click (eventListener globalClickListener) false

    isTestnet' <- isTestnet <$> hostname

    pure
        { initialState:
            set lang locale $
            set testnet isTestnet' $
            state
        , foldp: Ex.update
        , view
        , inputs:
              [ clockSignal
              , actionSignal
              -- Important note:
              -- routeSignal has to be the last signal in row !!!
              , routeSignal
              ]
        }

appSelector :: String
appSelector = "#explorer"

type WebApp = App (DOMEvent -> Ex.Action) Ex.Action Ex.State

main :: forall eff . Ex.State -> Eff (CoreEffects (AppEffects eff)) WebApp
main state = do
    actionChannel <- channel Ex.NoOp
    appConfig <- commonConfig state actionChannel
    config <- case state ^. syncAction of
                  SyncByPolling -> pollingConfig appConfig
                  SyncBySocket -> socketConfig appConfig actionChannel
    app <- start config
    _ <- renderToDOM appSelector app.markup app.input

    -- Trigger `UpdateView` after starting app
    -- to run side effects which are needed by each route
    -- Because it's not triggered by Pux 10.x - maybe a bug???
    _ <- window >>=
            location >>=
                pathname >>= send actionChannel <<< Ex.UpdateView <<< match

    pure app

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.SocketIO.Client (connect, on)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (click)
import DOM.HTML.Location (pathname)
import DOM.HTML.Types (htmlDocumentToEventTarget)
import DOM.HTML.Window (document, location)
import Data.Lens ((^.), set)
import Data.Maybe (Maybe(..), fromMaybe)
import Explorer.Api.Socket (addressTxsUpdatedEventHandler, blocksPageUpdatedEventHandler, callYouEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, toEvent, txsUpdatedHandler) as Ex
import Explorer.I18n.Lang (Language(..), detectLocale)
import Explorer.Lenses.State (connection, testnet, lang, socket, syncAction)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..), ActionChannel) as Ex
import Explorer.Types.App (AppEffects)
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (SyncAction(..), hostname, isTestnet, isProduction, secureProtocol)
import Explorer.View.Layout (view)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, start)
import Pux.DOM.Events (DOMEvent)
import Pux.DOM.History (sampleURL)
import Pux.Renderer.React (renderToDOM)
import Signal (Signal, (~>))
import Signal.Channel (channel, send, subscribe)
import Signal.Time (every, second)

type AppConfig eff = (Config (DOMEvent -> Ex.Action) Ex.Action Ex.State (AppEffects eff))

-- | Config to synchronize data by socket-io
socketConfig :: forall eff . (AppConfig eff) -> Ex.ActionChannel -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
socketConfig appConfig actionChannel = do
    -- socket
    let pingSignal = every (10.0 * second) ~> const Ex.SocketPing
    socketHost <- Ex.mkSocketHost (secureProtocol isProduction) <$> hostname
    socket' <- connect socketHost
    _ <- on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
    _ <- on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
    _ <- on socket' (Ex.toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
    _ <- on socket' (Ex.toEvent BlocksLastPageUpdated) $ Ex.blocksPageUpdatedEventHandler actionChannel
    _ <- on socket' (Ex.toEvent AddrUpdated) $ Ex.addressTxsUpdatedEventHandler actionChannel
    -- Note:
    -- `CallYou` is the answer of `CallMe`.
    -- Handling both events are needed a to be connected with socket.io manually
    _ <- on socket' (Ex.toEvent CallYou) $ Ex.callYouEventHandler actionChannel
    pure $ appConfig
        { initialState = set (socket <<< connection) (Just socket') appConfig.initialState
        , inputs = [ pingSignal ] <> appConfig.inputs
        }

-- | Config to synchronize data by polling
pollingConfig :: forall eff . (AppConfig eff) -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
pollingConfig appConfig =
    let reloadSignal = every (60.0 * second) ~> const Ex.Reload in
    pure $ appConfig
        { inputs = [ reloadSignal ] <> appConfig.inputs
        }

-- | Common config
commonConfig :: forall eff . Ex.State -> Ex.ActionChannel -> Eff (CoreEffects (AppEffects eff)) (AppConfig eff)
commonConfig state actionChannel = do
    -- routing
    urlSignal <- sampleURL =<< window
    let routeSignal = urlSignal ~> (Ex.UpdateView <<< match)
    -- timer
    let clockSignal = every second ~> const Ex.UpdateClock
    -- detected locale
    locale <- fromMaybe English <$> detectLocale
    -- register actionSignal
    let actionSignal = subscribe actionChannel :: Signal Ex.Action
    -- register global (document) click listener
    -- globalClickListener :: forall eff. Event -> Eff (channel :: CHANNEL | eff) Unit
    let globalClickListener event = send actionChannel $ Ex.DocumentClicked event

    _ <- window >>=
            document >>=
                htmlDocumentToEventTarget >>>
                    addEventListener click (eventListener globalClickListener) false

    isTestnet' <- isTestnet <$> hostname

    pure
        { initialState:
            set lang locale $
            set testnet isTestnet' $
            state
        , foldp: Ex.update
        , view
        , inputs:
              [
              -- clockSignal
              actionSignal
              -- Important note:
              -- routeSignal has to be the last signal in row !!!
              , routeSignal
              ]
        }

appSelector :: String
appSelector = "#explorer"

type WebApp = App (DOMEvent -> Ex.Action) Ex.Action Ex.State

main :: forall eff . Ex.State -> Eff (CoreEffects (AppEffects eff)) WebApp
main state = do
    actionChannel <- channel Ex.NoOp
    appConfig <- commonConfig state actionChannel
    config <- case state ^. syncAction of
                  SyncByPolling -> pollingConfig appConfig
                  SyncBySocket -> socketConfig appConfig actionChannel
    app <- start config
    _ <- renderToDOM appSelector app.markup app.input

    -- Trigger `UpdateView` after starting app
    -- to run side effects which are needed by each route
    -- Because it's not triggered by Pux 10.x - maybe a bug???
    _ <- window >>=
            location >>=
                pathname >>= send actionChannel <<< Ex.UpdateView <<< match

    pure app