Updated listeners to be expressed in the same way in main function

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (\s -> s.coordinate == coordinate)

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing ((\i -> squares !! i) <$> (getCoordinateIndex coordinate squares))

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false ((\p -> p.player == player) <$> square.piece)

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  in vx < x && x < vx + renderSize &&
     vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex from grid.squares)
      toIndex = fromJust (getCoordinateIndex to grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = renderPage st (Just e)

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (\s -> s.coordinate == coordinate)

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing ((\i -> squares !! i) <$> (getCoordinateIndex coordinate squares))

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false ((\p -> p.player == player) <$> square.piece)

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  in vx < x && x < vx + renderSize &&
     vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex from grid.squares)
      toIndex = fromJust (getCoordinateIndex to grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> renderHighlight ctx state.grid.squares (Just square.coordinate)
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


use block strings for foreign imports

use block strings for foreign imports

module Data.Foldable where

import Prelude
import Control.Apply
import Data.Either
import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Monoid.First
import Data.Tuple

class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

instance foldableArray :: Foldable [] where
  foldr f z xs = foldrArray f z xs

  foldl f z xs = foldlArray f z xs

  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = x `f` z

  foldl _ z (Left _)  = z
  foldl f z (Right x) = z `f` x

  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z

  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x

  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableRef :: Foldable Ref where
  foldr f z (Ref x) = x `f` z

  foldl f z (Ref x) = z `f` x

  foldMap f (Ref x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = x `f` z

  foldl f z (Tuple _ x) = z `f` x

  foldMap f (Tuple _ x) = f x

fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m Unit
for_ = flip traverse_

sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m Unit
sequence_ = traverse_ id

mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

intercalate :: forall f m. (Foldable f, Monoid m) => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init = true } x = { init: false, acc: x }
  go { acc = acc } x   = { init: false, acc: acc <> sep <> x }

and :: forall f. (Foldable f) => f Boolean -> Boolean
and = foldl (&&) true

or :: forall f. (Foldable f) => f Boolean -> Boolean
or = foldl (||) false

any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
any p = or <<< foldMap (\x -> [p x])

all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
all p = and <<< foldMap (\x -> [p x])

sum :: forall f. (Foldable f) => f Number -> Number
sum = foldl (+) 0

product :: forall f. (Foldable f) => f Number -> Number
product = foldl (*) 1

elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
elem = any  <<< (==)

notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
notElem x = not <<< elem x

find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p f = case foldMap (\x -> if p x then [x] else []) f of
  (x:_) -> Just x
  []    -> Nothing

lookup :: forall a b f. (Eq a, Foldable f) => a -> f (Tuple a b) -> Maybe b
lookup a f = runFirst $ foldMap (\(Tuple a' b) -> First (if a == a' then Just b else Nothing)) f

foreign import foldrArray """
  function foldrArray(f) {
    return function(z) {
      return function(xs) {
        var acc = z;
        for (var i = xs.length - 1; i >= 0; --i) {
          acc = f(xs[i])(acc);
        }
        return acc;
      }
    }
  }""" :: forall a b. (a -> b -> b) -> b -> [a] -> b

foreign import foldlArray """
  function foldlArray(f) {
    return function(z) {
      return function(xs) {
        var acc = z;
        for (var i = 0, len = xs.length; i < len; ++i) {
          acc = f(acc)(xs[i]);
        }
        return acc;
      }
    }
  }""" :: forall a b. (b -> a -> b) -> b -> [a] -> b

module Data.Foldable where

import Prelude
import Control.Apply
import Data.Either
import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Monoid.First
import Data.Tuple

class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

instance foldableArray :: Foldable [] where
  foldr f z xs = foldrArray f z xs

  foldl f z xs = foldlArray f z xs

  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = x `f` z

  foldl _ z (Left _)  = z
  foldl f z (Right x) = z `f` x

  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z

  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x

  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableRef :: Foldable Ref where
  foldr f z (Ref x) = x `f` z

  foldl f z (Ref x) = z `f` x

  foldMap f (Ref x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = x `f` z

  foldl f z (Tuple _ x) = z `f` x

  foldMap f (Tuple _ x) = f x

fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m Unit
for_ = flip traverse_

sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m Unit
sequence_ = traverse_ id

mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

intercalate :: forall f m. (Foldable f, Monoid m) => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init = true } x = { init: false, acc: x }
  go { acc = acc } x   = { init: false, acc: acc <> sep <> x }

and :: forall f. (Foldable f) => f Boolean -> Boolean
and = foldl (&&) true

or :: forall f. (Foldable f) => f Boolean -> Boolean
or = foldl (||) false

any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
any p = or <<< foldMap (\x -> [p x])

all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
all p = and <<< foldMap (\x -> [p x])

sum :: forall f. (Foldable f) => f Number -> Number
sum = foldl (+) 0

product :: forall f. (Foldable f) => f Number -> Number
product = foldl (*) 1

elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
elem = any  <<< (==)

notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
notElem x = not <<< elem x

find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p f = case foldMap (\x -> if p x then [x] else []) f of
  (x:_) -> Just x
  []    -> Nothing

lookup :: forall a b f. (Eq a, Foldable f) => a -> f (Tuple a b) -> Maybe b
lookup a f = runFirst $ foldMap (\(Tuple a' b) -> First (if a == a' then Just b else Nothing)) f

foreign import foldrArray
  "function foldrArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = xs.length - 1; i >= 0; --i) {\
  \        acc = f(xs[i])(acc);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (a -> b -> b) -> b -> [a] -> b

foreign import foldlArray
  "function foldlArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = 0, len = xs.length; i < len; ++i) {\
  \        acc = f(acc)(xs[i]);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (b -> a -> b) -> b -> [a] -> b


[CSE-193] Add tests for handling page numbers

while switching filter of genesis addresses

module Explorer.Update.Test where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (index, length, (..), (:))
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Maybe (fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Api.Types (SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (connected, currentAddressSummary, dbViewBlockPagination, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, gblAddressInfosPagination, gblMaxAddressInfosPagination, genesisBlockViewState, lang, latestBlocks, latestTransactions, loading, socket, subscriptions, viewStates)
import Explorer.State (initialState, mkSocketSubscriptionItem)
import Explorer.Test.MockFactory (mkCBlockEntry, mkCTxBrief, mkEmptyCAddressSummary, mkEmptyCTxEntry, mkCTxBriefs, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx, setTxOfAddressSummary)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (PageNumber(..), PageSize(..))
import Explorer.Update (update)
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.RemoteData (RemoteData(..), _Success, isLoading, isNotAsked, withDefault)
import Pos.Explorer.Socket.Methods (Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, caTxList)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testUpdate :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testUpdate =
    describe "Explorer.Update" do

        describe "uses action SetLanguage" do
            it "to update language"
                let effModel =  update (SetLanguage German) initialState
                    state = _.state effModel
                    result = state ^. lang
                in result `shouldEqual` German

        describe "uses action SocketBlocksPageUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let totalPages = 70
                blockA = setEpochSlotOfBlock 0 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 0 2 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 0 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 1 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
            it "to update latestBlocks (but not currentPage number) at the last (current) page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        , blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "to update latestBlocks and currentPage number to switch to the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success <<< PageNumber $ totalPages - 1)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "not to update latestBlocks and current page number since we are not at the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        ]
                    newBlocks =
                        [ blockB
                        , blockC
                        , blockD
                        ]
                    currentPage = totalPages - 2
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber currentPage) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blockResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blockResult) `shouldEqual` (gShow currentBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber currentPage)
            it "to count total pages"
                let blocks = [ blockC ]
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "handles SocketAddressTxsUpdated action" do
            -- mock `currentAddressSummary` first
            let addrs = setTxOfAddressSummary (mkCTxBriefs (9..0)) mkEmptyCAddressSummary
                initialState' =
                    set currentAddressSummary (Success addrs) initialState
                latestTx = mkCTxBrief 19
                txs = latestTx : mkCTxBriefs (18..10)
                effModel = update (SocketAddressTxsUpdated (Right txs)) initialState'
                state = _.state effModel
                updatedAddrs = state ^. (currentAddressSummary <<< _Success <<< _CAddressSummary <<< caTxList)

            it "to add all new transactions" do
                length updatedAddrs `shouldEqual` 20
            it "to add latest transactions on top of txs list"
                let mAddr = index updatedAddrs 0 in
                fromMaybe "not-found" (gShow <$> mAddr) `shouldEqual` (gShow latestTx)

        describe "handles RequestPaginatedBlocks action" do
            let effModel = update DashboardRequestBlocksTotalPages initialState
                state = _.state effModel
            it "to set loading state of dbViewMaxBlockPaginations" do
                (isLoading $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination)) `shouldEqual` true

        describe "handles RequestPaginatedBlocks action" do
            let pageNumber = PageNumber 2
                effModel = update (RequestPaginatedBlocks pageNumber (PageSize 1)) initialState
                state = _.state effModel
            it "to set dbViewLoadingBlockPagination to true" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination)) `shouldEqual` true
            it "to not update state of latestBlocks" do
                (isNotAsked $ state ^. latestBlocks) `shouldEqual` true
            it "to update dbViewBlockPagination"
                let result = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                in (gShow result) `shouldEqual` (gShow pageNumber)

        describe "handles DashboardReceiveBlocksTotalPages action" do
            let totalPages = 70
                effModel = update (DashboardReceiveBlocksTotalPages $ Right totalPages) initialState
                state = _.state effModel
            it "to update dbViewMaxBlockPagination to number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "uses action ReceivePaginatedBlocks" do
            -- Mock blocks with epoch, slots and hashes
            let blockA = setEpochSlotOfBlock 2 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 2 0 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 9 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 8 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
                blockE = setEpochSlotOfBlock 1 7 $ setHashOfBlock (mkCHash "E") mkCBlockEntry
                currentBlocks =
                    [ blockA
                    , blockB
                    , blockC
                    ]
                pageNumber = PageNumber 2
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                totalPages = 10
                effModel = update (ReceivePaginatedBlocks (Right (Tuple totalPages paginatedBlocks))) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)
            it "to update number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages
            it "to set loading to false" do
                (state ^. loading) `shouldEqual` false
            it "to set dbViewLoadingBlockPagination to false" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination))
                    `shouldEqual` false

        describe "uses action SocketTxsUpdated" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                txD = setTimeOfTx (mkTime 2.1) $ setIdOfTx (mkCTxId "D") mkEmptyCTxEntry
                currentTxs =
                    [ txA
                    , txB
                    ]
                -- set `latestTransactions` to simulate that we have already txs before
                initialState' =
                    set latestTransactions (Success currentTxs) initialState
                newTxs =
                    [ txA
                    , txC
                    , txD
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState'
                state = _.state effModel
            it "to update latestTransactions w/o duplicates and sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txD
                        , txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveLastTxs action" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                newTxs =
                    [ txA
                    , txC
                    , txB
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState
                state = _.state effModel
            it "to update latestTransactions sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveGenesisAddressInfoTotalPages action" do
            it "to update gblMaxAddressInfosPagination w/ number of total pages"
                let totalPages = 5
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $
                                state ^. (viewStates <<< genesisBlockViewState <<< gblMaxAddressInfosPagination)
                in result `shouldEqual` totalPages
            it "to leave gblMaxAddressInfosPagination untouched"
                let totalPages = 20
                    currentPage = 10
                    -- set current page to simulate that we have paginated before
                    initialState' =
                        set (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                            (PageNumber currentPage)
                            initialState
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState'
                    state = _.state effModel
                    currentPageResult = unwrap $ state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                in currentPageResult `shouldEqual` currentPage
            it "to update gblMaxAddressInfosPagination untouched"
                let totalPages = 10
                    currentPage = 20
                    -- set current page to simulate that we have paginated before
                    initialState' =
                        set (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                            (PageNumber currentPage)
                            initialState
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState'
                    state = _.state effModel
                    currentPageResult = unwrap $ state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                in currentPageResult `shouldEqual` totalPages

        describe "uses action SocketConnected" do
            it "to update connection to connected"
                let effModel = update (SocketConnected true) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` true
            it "to update connection to disconnected"
                let effModel = update (SocketConnected false) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` false

        describe "uses action SocketAddSubscription" do
            it "to add a first subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in (gShow result) `shouldEqual` (gShow [subItem])
            it "to add another subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        ]
                                        initialState
                    subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                    expected =  [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketRemoveSubscription" do
            it "to not remove anything, if we do have an empty list of subscriptions"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketRemoveSubscription subItem) initialState
                    state = _.state effModel
                    result = length $ state ^. socket <<< subscriptions
                in result `shouldEqual` 0
            it "to remove a subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update (SocketRemoveSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in  (gShow result) `shouldEqual`
                    (gShow [mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData])

        describe "uses action SocketClearSubscriptions" do

            it "to remove nothing if no subscription available"
                let effModel = update SocketClearSubscriptions initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

            it "to remove all subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update SocketClearSubscriptions initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

module Explorer.Update.Test where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (index, length, (..), (:))
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Maybe (fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Api.Types (SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (connected, currentAddressSummary, dbViewBlockPagination, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, lang, latestBlocks, latestTransactions, loading, socket, subscriptions)
import Explorer.State (initialState, mkSocketSubscriptionItem)
import Explorer.Test.MockFactory (mkCBlockEntry, mkCTxBrief, mkEmptyCAddressSummary, mkEmptyCTxEntry, mkCTxBriefs, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx, setTxOfAddressSummary)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (PageNumber(..), PageSize(..))
import Explorer.Update (update)
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.RemoteData (RemoteData(..), _Success, isLoading, isNotAsked, withDefault)
import Pos.Explorer.Socket.Methods (Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, caTxList)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testUpdate :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testUpdate =
    describe "Explorer.Update" do

        describe "uses action SetLanguage" do
            it "to update language"
                let effModel =  update (SetLanguage German) initialState
                    state = _.state effModel
                    result = state ^. lang
                in result `shouldEqual` German

        describe "uses action SocketBlocksPageUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let totalPages = 70
                blockA = setEpochSlotOfBlock 0 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 0 2 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 0 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 1 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
            it "to update latestBlocks (but not currentPage number) at the last (current) page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        , blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "to update latestBlocks and currentPage number to switch to the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success <<< PageNumber $ totalPages - 1)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "not to update latestBlocks and current page number since we are not at the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        ]
                    newBlocks =
                        [ blockB
                        , blockC
                        , blockD
                        ]
                    currentPage = totalPages - 2
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber currentPage) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blockResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blockResult) `shouldEqual` (gShow currentBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber currentPage)
            it "to count total pages"
                let blocks = [ blockC ]
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "handles SocketAddressTxsUpdated action" do
            -- mock `currentAddressSummary` first
            let addrs = setTxOfAddressSummary (mkCTxBriefs (9..0)) mkEmptyCAddressSummary
                initialState' =
                    set currentAddressSummary (Success addrs) initialState
                latestTx = mkCTxBrief 19
                txs = latestTx : mkCTxBriefs (18..10)
                effModel = update (SocketAddressTxsUpdated (Right txs)) initialState'
                state = _.state effModel
                updatedAddrs = state ^. (currentAddressSummary <<< _Success <<< _CAddressSummary <<< caTxList)

            it "to add all new transactions" do
                length updatedAddrs `shouldEqual` 20
            it "to add latest transactions on top of txs list"
                let mAddr = index updatedAddrs 0 in
                fromMaybe "not-found" (gShow <$> mAddr) `shouldEqual` (gShow latestTx)

        describe "handles RequestPaginatedBlocks action" do
            let effModel = update DashboardRequestBlocksTotalPages initialState
                state = _.state effModel
            it "to set loading state of dbViewMaxBlockPaginations" do
                (isLoading $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination)) `shouldEqual` true

        describe "handles RequestPaginatedBlocks action" do
            let pageNumber = PageNumber 2
                effModel = update (RequestPaginatedBlocks pageNumber (PageSize 1)) initialState
                state = _.state effModel
            it "to set dbViewLoadingBlockPagination to true" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination)) `shouldEqual` true
            it "to not update state of latestBlocks" do
                (isNotAsked $ state ^. latestBlocks) `shouldEqual` true
            it "to update dbViewBlockPagination"
                let result = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                in (gShow result) `shouldEqual` (gShow pageNumber)

        describe "handles DashboardReceiveBlocksTotalPages action" do
            let totalPages = 70
                effModel = update (DashboardReceiveBlocksTotalPages $ Right totalPages) initialState
                state = _.state effModel
            it "to update dbViewMaxBlockPagination to number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "uses action ReceivePaginatedBlocks" do
            -- Mock blocks with epoch, slots and hashes
            let blockA = setEpochSlotOfBlock 2 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 2 0 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 9 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 8 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
                blockE = setEpochSlotOfBlock 1 7 $ setHashOfBlock (mkCHash "E") mkCBlockEntry
                currentBlocks =
                    [ blockA
                    , blockB
                    , blockC
                    ]
                pageNumber = PageNumber 2
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                totalPages = 10
                effModel = update (ReceivePaginatedBlocks (Right (Tuple totalPages paginatedBlocks))) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)
            it "to update number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages
            it "to set loading to false" do
                (state ^. loading) `shouldEqual` false
            it "to set dbViewLoadingBlockPagination to false" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination))
                    `shouldEqual` false

        describe "uses action SocketTxsUpdated" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                txD = setTimeOfTx (mkTime 2.1) $ setIdOfTx (mkCTxId "D") mkEmptyCTxEntry
                currentTxs =
                    [ txA
                    , txB
                    ]
                -- set `latestTransactions` to simulate that we have already txs before
                initialState' =
                    set latestTransactions (Success currentTxs) initialState
                newTxs =
                    [ txA
                    , txC
                    , txD
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState'
                state = _.state effModel
            it "to update latestTransactions w/o duplicates and sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txD
                        , txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveLastTxs action" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                newTxs =
                    [ txA
                    , txC
                    , txB
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState
                state = _.state effModel
            it "to update latestTransactions sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketConnected" do
            it "to update connection to connected"
                let effModel = update (SocketConnected true) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` true
            it "to update connection to disconnected"
                let effModel = update (SocketConnected false) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` false

        describe "uses action SocketAddSubscription" do
            it "to add a first subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in (gShow result) `shouldEqual` (gShow [subItem])
            it "to add another subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        ]
                                        initialState
                    subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                    expected =  [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketRemoveSubscription" do
            it "to not remove anything, if we do have an empty list of subscriptions"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketRemoveSubscription subItem) initialState
                    state = _.state effModel
                    result = length $ state ^. socket <<< subscriptions
                in result `shouldEqual` 0
            it "to remove a subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update (SocketRemoveSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in  (gShow result) `shouldEqual`
                    (gShow [mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData])

        describe "uses action SocketClearSubscriptions" do

            it "to remove nothing if no subscription available"
                let effModel = update SocketClearSubscriptions initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

            it "to remove all subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update SocketClearSubscriptions initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0


Different message if first deck author accesses is not empty

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component: H.lifecycleComponent { initializer: Just $ right $ H.action $ Init, finalizer: Nothing, render, eval}
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          (addCardGuideText state.input))
    ⊕ [ HH.ul_ $ map nextButton CT.insertableCardTypes ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ CT.CardType → String
  cardTitle cty = "Insert " ⊕ CT.cardName cty ⊕ " card"

  nextButton ∷ CT.CardType → NextHTML
  nextButton cty =
    HH.li_
      [ HH.button attrs
          [ CT.lightCardGlyph cty
          , HH.p_ [ HH.text (CT.cardName cty) ]
          ]
      ]
    where
    enabled = Str.contains filterString (Str.toLower $ CT.cardName cty)
    attrs =
      [ HP.title $ cardTitle cty
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle cty
      ] ⊕ (guard (not $ takesInput state.input cty)
             $> HP.classes [ HH.className "sd-button-warning" ])
        ⊕ (guard enabled
             $> HE.onClick (HE.input_ (right ∘ addCardOrPresentReason state.input cty)))

  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."
  addCardGuideText = maybe addCardGuideTextEmptyDeck (const addCardGuideTextNonEmptyDeck)

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    H.modify (State._input .~ value.input) $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

addCardOrPresentReason ∷ ∀ a. Maybe Port.Port → CT.CardType → a -> Query a
addCardOrPresentReason input cardType a =
  if takesInput input cardType
     then AddCard cardType a
     else PresentReason input cardType a

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false) *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) = H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (Init next) = do
  H.modify ∘ (State._presentAddCardGuide .~ _) ∘ not =<< getDismissedAddCardGuideBefore
  pure next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Lens ((.~))
import Data.String as Str

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component: H.lifecycleComponent { initializer: Just $ right $ H.action $ Init, finalizer: Nothing, render, eval}
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          addCardGuideTextEmptyDeck)
    ⊕ [ HH.ul_ $ map nextButton CT.insertableCardTypes ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ CT.CardType → String
  cardTitle cty = "Insert " ⊕ CT.cardName cty ⊕ " card"

  nextButton ∷ CT.CardType → NextHTML
  nextButton cty =
    HH.li_
      [ HH.button attrs
          [ CT.lightCardGlyph cty
          , HH.p_ [ HH.text (CT.cardName cty) ]
          ]
      ]
    where
    enabled = Str.contains filterString (Str.toLower $ CT.cardName cty)
    attrs =
      [ HP.title $ cardTitle cty
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle cty
      ] ⊕ (guard (not $ takesInput state.input cty)
             $> HP.classes [ HH.className "sd-button-warning" ])
        ⊕ (guard enabled
             $> HE.onClick (HE.input_ (right ∘ addCardOrPresentReason state.input cty)))

  cardGuideText =
    "Cards retreive, process and present data, forms, charts and more."
      ⊕ " Every card creates an output which can be passed to another."
      ⊕ " By stacking cards into decks you can find valuable insights"
      ⊕ " and do amazing things."
  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    H.modify (State._input .~ value.input) $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

addCardOrPresentReason ∷ ∀ a. Maybe Port.Port → CT.CardType → a -> Query a
addCardOrPresentReason input cardType a =
  if takesInput input cardType
     then AddCard cardType a
     else PresentReason input cardType a

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false) *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) = H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (Init next) = do
  H.modify ∘ (State._presentAddCardGuide .~ _) ∘ not =<< getDismissedAddCardGuideBefore
  pure next


remove unused imports

remove unused imports

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe (Just))
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get)
import Network.HTTP.RequestHeader (RequestHeader (ContentType))
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta)
import Daedalus.Constants (backendPrefix)
import Data.MediaType.Common (applicationJSON)

-- TODO: remove traces, they are adding to increase verbosity in development
makeRequest :: forall eff a. (Generic a) => String -> Aff (ajax :: AJAX | eff) a
makeRequest url = do
  res <- get $ backendPrefix <> url
  either throwError pure $ decodeResult res

decodeResult :: forall a eff. (Generic a) => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = makeRequest $ "/api/get_wallets"

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = makeRequest $ "/api/get_wallet/" <> _address addr

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = makeRequest $ "/api/history/" <> _address addr

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = do
  res <- affjax $ defaultRequest
    -- TODO: use url constructor
    { url = backendPrefix <> "/api/send/" <> _address addrFrom <> "/" <> _address addrTo <> "/" <> show (_coin amount)
    , method = Left POST
    }
  either throwError pure $ decodeResult res

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/new_wallet"
    , method = Left POST
    , content = Just <<< show $ encodeJson wMeta
    , headers = [ContentType applicationJSON]
    }
  either throwError pure $ decodeResult res

--updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) ()
--updateTransaction addr ctxId ctxMeta = do
--  res <- affjax $ defaultRequest
--    { url = backendPrefix <> "/api/update_transaction/" <> _address addr <> "/" <> _ctxIdValue ctxId
--    , method = Left POST
--    , content = Just $ encodeJson ctxMeta
--    }
--  either throwError pure $ decodeResult res

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/update_wallet/" <> _address addr
    , method = Left POST
    , content = Just <<< show $ encodeJson wMeta
    , headers = [ContentType applicationJSON]
    }
  either throwError pure $ decodeResult res

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = do
  -- FIXME: use DELETE method
  res <- affjax $ defaultRequest { url = backendPrefix <> "/api/delete_wallet/" <> _address addr, method = Left POST }
  either throwError pure $ decodeResult res

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(POST, DELETE))
import Data.Maybe (Maybe (Just))
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get)
import Network.HTTP.RequestHeader (RequestHeader (ContentType))
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, _ctxIdValue, CTxId, CTxMeta)
import Daedalus.Constants (backendPrefix)
import Data.MediaType.Common (applicationJSON)

-- TODO: remove traces, they are adding to increase verbosity in development
makeRequest :: forall eff a. (Generic a) => String -> Aff (ajax :: AJAX | eff) a
makeRequest url = do
  res <- get $ backendPrefix <> url
  either throwError pure $ decodeResult res

decodeResult :: forall a eff. (Generic a) => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = makeRequest $ "/api/get_wallets"

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = makeRequest $ "/api/get_wallet/" <> _address addr

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = makeRequest $ "/api/history/" <> _address addr

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = do
  res <- affjax $ defaultRequest
    -- TODO: use url constructor
    { url = backendPrefix <> "/api/send/" <> _address addrFrom <> "/" <> _address addrTo <> "/" <> show (_coin amount)
    , method = Left POST
    }
  either throwError pure $ decodeResult res

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/new_wallet"
    , method = Left POST
    , content = Just <<< show $ encodeJson wMeta
    , headers = [ContentType applicationJSON]
    }
  either throwError pure $ decodeResult res

--updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) ()
--updateTransaction addr ctxId ctxMeta = do
--  res <- affjax $ defaultRequest
--    { url = backendPrefix <> "/api/update_transaction/" <> _address addr <> "/" <> _ctxIdValue ctxId
--    , method = Left POST
--    , content = Just $ encodeJson ctxMeta
--    }
--  either throwError pure $ decodeResult res

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/update_wallet/" <> _address addr
    , method = Left POST
    , content = Just <<< show $ encodeJson wMeta
    , headers = [ContentType applicationJSON]
    }
  either throwError pure $ decodeResult res

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = do
  -- FIXME: use DELETE method
  res <- affjax $ defaultRequest { url = backendPrefix <> "/api/delete_wallet/" <> _address addr, method = Left POST }
  either throwError pure $ decodeResult res


Re-export && and || from BooleanAlgebra

Re-export && and || from BooleanAlgebra

module Data.BooleanAlgebra
  ( class BooleanAlgebra
  , module Data.HeytingAlgebra
  ) where

import Data.HeytingAlgebra (class HeytingAlgebra, ff, tt, implies, conj, disj, not, (&&), (||))
import Data.Unit (Unit)

-- | The `BooleanAlgebra` type class represents types that behave like boolean
-- | values.
-- |
-- | Instances should satisfy the following laws in addition to the
-- | `HeytingAlgebra` law:
-- |
-- | - Excluded middle:
-- |   - `a || not a = tt`
class HeytingAlgebra a <= BooleanAlgebra a

instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
instance booleanAlgebraUnit :: BooleanAlgebra Unit

module Data.BooleanAlgebra
  ( class BooleanAlgebra
  , module Data.HeytingAlgebra
  ) where

import Data.HeytingAlgebra (class HeytingAlgebra, ff, tt, implies, conj, disj, not)
import Data.Unit (Unit)

-- | The `BooleanAlgebra` type class represents types that behave like boolean
-- | values.
-- |
-- | Instances should satisfy the following laws in addition to the
-- | `HeytingAlgebra` law:
-- |
-- | - Excluded middle:
-- |   - `a || not a = tt`
class HeytingAlgebra a <= BooleanAlgebra a

instance booleanAlgebraBoolean :: BooleanAlgebra Boolean
instance booleanAlgebraUnit :: BooleanAlgebra Unit