Add EXCEPTION to stdout and stderr

Add EXCEPTION to stdout and stderr

calling `end` will make them throw

-- | Bindings to the global `process` object in Node.js. See also [the Node API documentation](https://nodejs.org/api/process.html)
module Node.Process
  ( PROCESS()
  , onBeforeExit
  , onExit
  , onSignal
  , argv
  , execArgv
  , execPath
  , chdir
  , cwd
  , getEnv
  , lookupEnv
  , setEnv
  , pid
  , platform
  , exit
  , stdin
  , stdout
  , stderr
  , stdoutIsTTY
  , version
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.StrMap (StrMap())
import Data.StrMap as StrMap
import Node.Stream (Readable(), Writable())
import Unsafe.Coerce (unsafeCoerce)

import Node.Platform (Platform())
import Node.Platform as Platform

-- | An effect tracking interaction with the global `process` object.
foreign import data PROCESS :: !

-- YOLO
foreign import process :: forall props. { | props }

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Register a callback to be performed when the event loop empties, and
-- | Node.js is about to exit. Asynchronous calls can be made in the callback,
-- | and if any are made, it will cause the process to continue a little longer.
foreign import onBeforeExit :: forall eff. Eff (process :: PROCESS | eff) Unit -> Eff (process :: PROCESS | eff) Unit

-- | Register a callback to be performed when the process is about to exit.
-- | Any work scheduled via asynchronous calls made here will not be performed
-- | in time.
-- |
-- | The argument to the callback is the exit code which the process is about
-- | to exit with.
foreign import onExit :: forall eff. (Int -> Eff (process :: PROCESS | eff) Unit) -> Eff (process :: PROCESS | eff) Unit

-- | Install a handler for a particular signal.
foreign import onSignal :: forall eff. String -> Eff (process :: PROCESS | eff) Unit -> Eff (process :: PROCESS | eff) Unit

-- | Register a callback to run as soon as the current event loop runs to
-- | completion.
nextTick :: forall eff. Eff eff Unit -> Eff eff Unit
nextTick callback = mkEff \_ -> process.nextTick callback

-- | Get an array containing the command line arguments. Be aware
-- | that this can change over the course of the program.
argv :: forall eff. Eff (process :: PROCESS | eff) (Array String)
argv = mkEff \_ -> process.argv

-- | Node-specific options passed to the `node` executable. Be aware that
-- | this can change over the course of the program.
execArgv :: forall eff. Eff (process :: PROCESS | eff) (Array String)
execArgv = mkEff \_ -> process.execArgv

-- | The absolute pathname of the `node` executable that started the
-- | process.
execPath :: forall eff. Eff (process :: PROCESS | eff) String
execPath = mkEff \_ -> process.execPath

-- | Change the current working directory of the process. If the current
-- | directory could not be changed, an exception will be thrown.
foreign import chdir :: forall eff. String -> Eff (err :: EXCEPTION, process :: PROCESS | eff) Unit

-- | Get the current working directory of the process.
cwd :: forall eff. Eff (process :: PROCESS | eff) String
cwd = process.cwd

-- | Get a copy of the current environment.
getEnv :: forall eff. Eff (process :: PROCESS | eff) (StrMap String)
getEnv = mkEff \_ -> process.env

-- | Lookup a particular environment variable.
lookupEnv :: forall eff. String -> Eff (process :: PROCESS | eff) (Maybe String)
lookupEnv k = StrMap.lookup k <$> getEnv

-- | Set an environment variable.
foreign import setEnv :: forall eff. String -> String -> Eff (process :: PROCESS | eff) Unit

pid :: Int
pid = process.pid

platform :: Platform
platform = fromJust (Platform.fromString process.platform)

-- | Cause the process to exit with the supplied integer code. An exit code
-- | of 0 is normally considered successful, and anything else is considered a
-- | failure.
foreign import exit :: forall eff. Int -> Eff (process :: PROCESS | eff) Unit

-- | The standard input stream. Note that this stream will never emit an `end`
-- | event, so any handlers attached via `onEnd` will never be called.
stdin :: forall eff. Readable () (console :: CONSOLE | eff)
stdin = process.stdin

-- | The standard output stream. Note that this stream cannot be closed; calling
-- | `end` will result in an exception being thrown.
stdout :: forall eff. Writable () (console :: CONSOLE, err :: EXCEPTION | eff)
stdout = process.stdout

-- | The standard error stream. Note that this stream cannot be closed; calling
-- | `end` will result in an exception being thrown.
stderr :: forall eff. Writable () (console :: CONSOLE, err :: EXCEPTION | eff)
stderr = process.stderr

-- | Check whether the process is being run inside a TTY context
stdoutIsTTY :: Boolean
stdoutIsTTY = process.stdout.isTTY

-- | Get the Node.js version.
version :: String
version = process.version

-- | Bindings to the global `process` object in Node.js. See also [the Node API documentation](https://nodejs.org/api/process.html)
module Node.Process
  ( PROCESS()
  , onBeforeExit
  , onExit
  , onSignal
  , argv
  , execArgv
  , execPath
  , chdir
  , cwd
  , getEnv
  , lookupEnv
  , setEnv
  , pid
  , platform
  , exit
  , stdin
  , stdout
  , stderr
  , stdoutIsTTY
  , version
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.StrMap (StrMap())
import Data.StrMap as StrMap
import Node.Stream (Readable(), Writable())
import Unsafe.Coerce (unsafeCoerce)

import Node.Platform (Platform())
import Node.Platform as Platform

-- | An effect tracking interaction with the global `process` object.
foreign import data PROCESS :: !

-- YOLO
foreign import process :: forall props. { | props }

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Register a callback to be performed when the event loop empties, and
-- | Node.js is about to exit. Asynchronous calls can be made in the callback,
-- | and if any are made, it will cause the process to continue a little longer.
foreign import onBeforeExit :: forall eff. Eff (process :: PROCESS | eff) Unit -> Eff (process :: PROCESS | eff) Unit

-- | Register a callback to be performed when the process is about to exit.
-- | Any work scheduled via asynchronous calls made here will not be performed
-- | in time.
-- |
-- | The argument to the callback is the exit code which the process is about
-- | to exit with.
foreign import onExit :: forall eff. (Int -> Eff (process :: PROCESS | eff) Unit) -> Eff (process :: PROCESS | eff) Unit

-- | Install a handler for a particular signal.
foreign import onSignal :: forall eff. String -> Eff (process :: PROCESS | eff) Unit -> Eff (process :: PROCESS | eff) Unit

-- | Register a callback to run as soon as the current event loop runs to
-- | completion.
nextTick :: forall eff. Eff eff Unit -> Eff eff Unit
nextTick callback = mkEff \_ -> process.nextTick callback

-- | Get an array containing the command line arguments. Be aware
-- | that this can change over the course of the program.
argv :: forall eff. Eff (process :: PROCESS | eff) (Array String)
argv = mkEff \_ -> process.argv

-- | Node-specific options passed to the `node` executable. Be aware that
-- | this can change over the course of the program.
execArgv :: forall eff. Eff (process :: PROCESS | eff) (Array String)
execArgv = mkEff \_ -> process.execArgv

-- | The absolute pathname of the `node` executable that started the
-- | process.
execPath :: forall eff. Eff (process :: PROCESS | eff) String
execPath = mkEff \_ -> process.execPath

-- | Change the current working directory of the process. If the current
-- | directory could not be changed, an exception will be thrown.
foreign import chdir :: forall eff. String -> Eff (err :: EXCEPTION, process :: PROCESS | eff) Unit

-- | Get the current working directory of the process.
cwd :: forall eff. Eff (process :: PROCESS | eff) String
cwd = process.cwd

-- | Get a copy of the current environment.
getEnv :: forall eff. Eff (process :: PROCESS | eff) (StrMap String)
getEnv = mkEff \_ -> process.env

-- | Lookup a particular environment variable.
lookupEnv :: forall eff. String -> Eff (process :: PROCESS | eff) (Maybe String)
lookupEnv k = StrMap.lookup k <$> getEnv

-- | Set an environment variable.
foreign import setEnv :: forall eff. String -> String -> Eff (process :: PROCESS | eff) Unit

pid :: Int
pid = process.pid

platform :: Platform
platform = fromJust (Platform.fromString process.platform)

-- | Cause the process to exit with the supplied integer code. An exit code
-- | of 0 is normally considered successful, and anything else is considered a
-- | failure.
foreign import exit :: forall eff. Int -> Eff (process :: PROCESS | eff) Unit

-- | The standard input stream. Note that this stream will never emit an `end`
-- | event, so any handlers attached via `onEnd` will never be called.
stdin :: forall eff. Readable () (console :: CONSOLE | eff)
stdin = process.stdin

-- | The standard output stream. Note that this stream cannot be closed; calling
-- | `end` will result in an exception being thrown.
stdout :: forall eff. Writable () (console :: CONSOLE | eff)
stdout = process.stdout

-- | The standard error stream. Note that this stream cannot be closed; calling
-- | `end` will result in an exception being thrown.
stderr :: forall eff. Writable () (console :: CONSOLE | eff)
stderr = process.stderr

-- | Check whether the process is being run inside a TTY context
stdoutIsTTY :: Boolean
stdoutIsTTY = process.stdout.isTTY

-- | Get the Node.js version.
version :: String
version = process.version


extra type signatures

extra type signatures


line refactor

line refactor

module Components.Common where

import React.DOM.SVG as S
import Thermite as T
import React (ReactElement)
import React.DOM.Props (unsafeMkProps)

rawview :: Array ReactElement -> T.Spec _ _ _ _
rawview h = T.simpleSpec T.defaultPerformAction render
  where
  render _ _ _ _ = h

linje :: Int -> Int -> Int -> Int -> ReactElement
linje x1 y1 x2 y2 =
  S.line
    [ p "x1" x1
    , p "y1" y1
    , p "x2" x2
    , p "y2" y2
    , p "stroke" "black"
    , p "stroke-width" 2
    ] []
    where p = unsafeMkProps

module Components.Common where

import React.DOM.SVG as S
import Thermite as T
import React (ReactElement)
import React.DOM.Props (unsafeMkProps)

rawview :: Array ReactElement -> T.Spec _ _ _ _
rawview h = T.simpleSpec T.defaultPerformAction render
  where
  render _ _ _ _ = h

linje :: Int -> Int -> Int -> Int -> ReactElement
linje x1 y1 x2 y2 =
  S.line
    [ unsafeMkProps "x1" x1
    , unsafeMkProps "y1" y1
    , unsafeMkProps "x2" x2
    , unsafeMkProps "y2" y2
    , unsafeMkProps "stroke" "black"
    , unsafeMkProps "stroke-width" 2
    ] []


Simplify superinstance constraints for ErrorT

module Control.Monad.Error.Trans where

import Control.Apply
import Control.Alt
import Control.Alternative
import Control.Plus
import Control.Monad.Error
import Control.Monad.Trans
import Control.MonadPlus
import Data.Either
import Data.Monoid
import Data.Tuple

newtype ErrorT e m a = ErrorT (m (Either e a))

runErrorT :: forall e m a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT x) = x

mapErrorT :: forall e1 e2 m1 m2 a b. (m1 (Either e1 a) -> m2 (Either e2 b)) -> ErrorT e1 m1 a -> ErrorT e2 m2 b
mapErrorT f m = ErrorT $ f (runErrorT m)

instance functorErrorT :: (Functor m) => Functor (ErrorT e m) where
  (<$>) f = ErrorT <<< (<$>) ((<$>) f) <<< runErrorT

instance applyErrorT :: (Apply m) => Apply (ErrorT e m) where
  (<*>) (ErrorT f) (ErrorT v) = ErrorT $ lift2 ($) <$> f <*> v

instance applicativeErrorT :: (Applicative m) => Applicative (ErrorT e m) where
  pure a = ErrorT $ pure $ Right a

instance altErrorT :: (Monad m, Error e) => Alt (ErrorT e m) where
  (<|>) x y = ErrorT $ runErrorT x >>= \e -> case e of
    Left _ -> runErrorT y
    r -> return r

instance plusErrorT :: (Monad m, Error e) => Plus (ErrorT e m) where
  empty = ErrorT (return (Left $ strMsg "No alternative"))

instance alternativeErrorT :: (Monad m, Error e) => Alternative (ErrorT e m)

instance bindErrorT :: (Monad m, Error e) => Bind (ErrorT e m) where
  (>>=) m f = ErrorT $ do
    a <- runErrorT m
    case a of
      Left e -> return $ Left e
      Right x -> runErrorT (f x)

instance monadErrorT :: (Monad m, Error e) => Monad (ErrorT e m)

instance monadPlusErrorT :: (Monad m, Error e) => MonadPlus (ErrorT e m)

instance monadTransErrorT :: (Error e) => MonadTrans (ErrorT e) where
  lift m = ErrorT $ do
    a <- m
    return $ Right a

liftListenError :: forall e m a w. (Monad m) => (m (Either e a) -> m (Tuple (Either e a) w)) -> ErrorT e m a -> ErrorT e m (Tuple a w)
liftListenError listen = mapErrorT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassError :: forall e m a w. (Monad m) => (m (Tuple (Either e a) (w -> w)) -> m (Either e a)) -> ErrorT e m (Tuple a (w -> w)) -> ErrorT e m a
liftPassError pass = mapErrorT $ \m -> pass $ do
  a <- m
  return $ case a of
    Left e -> Tuple (Left e) id
    Right (Tuple r f) -> Tuple (Right r) f

liftCallCCError :: forall e m a b. (((Either e a -> m (Either e b)) -> m (Either e a)) -> m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a
liftCallCCError callCC f = ErrorT $ callCC $ \c -> runErrorT (f (\a -> ErrorT $ c (Right a)))

module Control.Monad.Error.Trans where

import Control.Alt
import Control.Alternative
import Control.Plus
import Control.Monad.Error
import Control.Monad.Trans
import Control.MonadPlus
import Data.Either
import Data.Monoid
import Data.Tuple

newtype ErrorT e m a = ErrorT (m (Either e a))

runErrorT :: forall e m a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT x) = x

mapErrorT :: forall e1 e2 m1 m2 a b. (m1 (Either e1 a) -> m2 (Either e2 b)) -> ErrorT e1 m1 a -> ErrorT e2 m2 b
mapErrorT f m = ErrorT $ f (runErrorT m)

instance functorErrorT :: (Functor m) => Functor (ErrorT e m) where
  (<$>) f = ErrorT <<< (<$>) ((<$>) f) <<< runErrorT

instance applyErrorT :: (Functor m, Monad m) => Apply (ErrorT e m) where
  (<*>) f v = ErrorT $ do
    mf <- runErrorT f
    case mf of
      Left e -> return $ Left e
      Right k -> do
        mv <- runErrorT v
        return case mv of
          Left e -> Left e
          Right x -> Right (k x)

instance applicativeErrorT :: (Functor m, Monad m) => Applicative (ErrorT e m) where
  pure a = ErrorT $ pure $ Right a

instance altErrorT :: (Monad m, Error e) => Alt (ErrorT e m) where
  (<|>) x y = ErrorT $ runErrorT x >>= \e -> case e of
    Left _ -> runErrorT y
    r -> return r

instance plusErrorT :: (Monad m, Error e) => Plus (ErrorT e m) where
  empty = ErrorT (return (Left $ strMsg "No alternative"))

instance alternativeErrorT :: (Monad m, Error e) => Alternative (ErrorT e m)

instance bindErrorT :: (Monad m, Error e) => Bind (ErrorT e m) where
  (>>=) m f = ErrorT $ do
    a <- runErrorT m
    case a of
      Left e -> return $ Left e
      Right x -> runErrorT (f x)

instance monadErrorT :: (Monad m, Error e) => Monad (ErrorT e m)

instance monadPlusErrorT :: (Monad m, Error e) => MonadPlus (ErrorT e m)

instance monadTransErrorT :: (Error e) => MonadTrans (ErrorT e) where
  lift m = ErrorT $ do
    a <- m
    return $ Right a

liftListenError :: forall e m a w. (Monad m) => (m (Either e a) -> m (Tuple (Either e a) w)) -> ErrorT e m a -> ErrorT e m (Tuple a w)
liftListenError listen = mapErrorT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassError :: forall e m a w. (Monad m) => (m (Tuple (Either e a) (w -> w)) -> m (Either e a)) -> ErrorT e m (Tuple a (w -> w)) -> ErrorT e m a
liftPassError pass = mapErrorT $ \m -> pass $ do
  a <- m
  return $ case a of
    Left e -> Tuple (Left e) id
    Right (Tuple r f) -> Tuple (Right r) f

liftCallCCError :: forall e m a b. (((Either e a -> m (Either e b)) -> m (Either e a)) -> m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a
liftCallCCError callCC f = ErrorT $ callCC $ \c -> runErrorT (f (\a -> ErrorT $ c (Right a)))


Avoid using magic constant when creating game state

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
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 =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) 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
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just (createPiece playerOne)
                  else if hasPlayerTwo
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

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

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 -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      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, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 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
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              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 "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
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 =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) 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
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just (createPiece playerOne)
                  else if hasPlayerTwo
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers = { grid: (createGrid offset width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

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

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 -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      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, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 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
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              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 "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
      renderPage st Nothing
      return unit
    _ -> return unit


redundant parens in type signature

redundant parens in type signature

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , withArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , modifySTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , unsafeFreeze
  , toAssocArray
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.ST (ST)

import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `Array a`,
-- | except that mutation is allowed.
foreign import data STArray :: Type -> Type -> Type

-- | An element and its index.
type Assoc a = { value :: a, index :: Int }

-- | **DEPRECATED**: Use `unsafeFreeze` together with `runST` instead.
-- |
-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray
  :: forall a r
   . (forall h. Eff (st :: ST h | r) (STArray h a))
  -> Eff r (Array a)

-- | Perform an effect requiring a mutable array on a copy of an immutable array,
-- | safely returning the result as an immutable array.
withArray
  :: forall a b r h
   . (STArray h a -> Eff (st :: ST h | r) b)
   -> Array a
   -> Eff (st :: ST h | r) (Array a)
withArray f xs = do
  result <- thaw xs
  _ <- f result
  unsafeFreeze result

-- | O(1). Convert a mutable array to an immutable array, without copying. The mutable
-- | array must not be mutated afterwards.
unsafeFreeze :: forall a r h. STArray h a -> Eff (st :: ST h | r) (Array a)
unsafeFreeze = pure <<< (unsafeCoerce :: STArray h a -> Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. Array a -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array a)
freeze = copyImpl

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Read the value at the specified index in a mutable array.
peekSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Eff (st :: ST h | r) (Maybe a)
peekSTArray = peekSTArrayImpl Just Nothing

foreign import peekSTArrayImpl
  :: forall a h e r
   . (a -> r)
  -> r
  -> STArray h a
  -> Int
  -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray
  :: forall a h r
   . STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

-- | Append an element to the end of a mutable array. Returns the new length of
-- | the array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Int
pushSTArray arr a = pushAllSTArray arr [a]

-- | Append the values in an immutable array to the end of a mutable array.
-- | Returns the new length of the mutable array.
foreign import pushAllSTArray
  :: forall a h r
   . STArray h a
  -> Array a
  -> Eff (st :: ST h | r) Int

-- | Mutate the element at the specified index using the supplied function.
modifySTArray :: forall a h r. STArray h a -> Int -> (a -> a) -> Eff (st :: ST h | r) Boolean
modifySTArray xs i f = do
  entry <- peekSTArray xs i
  case entry of
    Just x  -> pokeSTArray xs i (f x)
    Nothing -> pure false

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Int
  -> Array a
  -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray
  :: forall a h r
   . STArray h a
  -> Eff (st :: ST h | r) (Array (Assoc a))

-- | Helper functions for working with mutable arrays using the `ST` effect.
-- |
-- | This module can be used when performance is important and mutation is a local effect.

module Data.Array.ST
  ( STArray(..)
  , Assoc()
  , runSTArray
  , withArray
  , emptySTArray
  , peekSTArray
  , pokeSTArray
  , pushSTArray
  , modifySTArray
  , pushAllSTArray
  , spliceSTArray
  , freeze, thaw
  , unsafeFreeze
  , toAssocArray
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.ST (ST)

import Data.Maybe (Maybe(..))
import Unsafe.Coerce (unsafeCoerce)

-- | A reference to a mutable array.
-- |
-- | The first type parameter represents the memory region which the array belongs to.
-- | The second type parameter defines the type of elements of the mutable array.
-- |
-- | The runtime representation of a value of type `STArray h a` is the same as that of `Array a`,
-- | except that mutation is allowed.
foreign import data STArray :: Type -> Type -> Type

-- | An element and its index.
type Assoc a = { value :: a, index :: Int }

-- | **DEPRECATED**: Use `unsafeFreeze` together with `runST` instead.
-- |
-- | Freeze a mutable array, creating an immutable array. Use this function as you would use
-- | `runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the reference from escaping the scope of `runSTArray`.
foreign import runSTArray
  :: forall a r
   . (forall h. Eff (st :: ST h | r) (STArray h a))
  -> Eff r (Array a)

-- | Perform an effect requiring a mutable array on a copy of an immutable array,
-- | safely returning the result as an immutable array.
withArray
  :: forall a b r h
   . (STArray h a -> Eff (st :: ST h | r) b)
   -> Array a
   -> Eff (st :: ST h | r) (Array a)
withArray f xs = do
  result <- thaw xs
  _ <- f result
  unsafeFreeze result

-- | O(1). Convert a mutable array to an immutable array, without copying. The mutable
-- | array must not be mutated afterwards.
unsafeFreeze :: forall a r h. STArray h a -> Eff (st :: ST h | r) (Array a)
unsafeFreeze = pure <<< (unsafeCoerce :: STArray h a -> Array a)

-- | Create an empty mutable array.
foreign import emptySTArray :: forall a h r. Eff (st :: ST h | r) (STArray h a)

-- | Create a mutable copy of an immutable array.
thaw :: forall a h r. Array a -> Eff (st :: ST h | r) (STArray h a)
thaw = copyImpl

-- | Create an immutable copy of a mutable array.
freeze :: forall a h r. STArray h a -> Eff (st :: ST h | r) (Array a)
freeze = copyImpl

foreign import copyImpl :: forall a b h r. a -> Eff (st :: ST h | r) b

-- | Read the value at the specified index in a mutable array.
peekSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Eff (st :: ST h | r) (Maybe a)
peekSTArray = peekSTArrayImpl Just Nothing

foreign import peekSTArrayImpl
  :: forall a h e r
   . (a -> r)
  -> r
  -> (STArray h a)
  -> Int
  -> (Eff (st :: ST h | e) r)

-- | Change the value at the specified index in a mutable array.
foreign import pokeSTArray
  :: forall a h r
   . STArray h a -> Int -> a -> Eff (st :: ST h | r) Boolean

-- | Append an element to the end of a mutable array. Returns the new length of
-- | the array.
pushSTArray :: forall a h r. STArray h a -> a -> Eff (st :: ST h | r) Int
pushSTArray arr a = pushAllSTArray arr [a]

-- | Append the values in an immutable array to the end of a mutable array.
-- | Returns the new length of the mutable array.
foreign import pushAllSTArray
  :: forall a h r
   . STArray h a
  -> Array a
  -> Eff (st :: ST h | r) Int

-- | Mutate the element at the specified index using the supplied function.
modifySTArray :: forall a h r. STArray h a -> Int -> (a -> a) -> Eff (st :: ST h | r) Boolean
modifySTArray xs i f = do
  entry <- peekSTArray xs i
  case entry of
    Just x  -> pokeSTArray xs i (f x)
    Nothing -> pure false

-- | Remove and/or insert elements from/into a mutable array at the specified index.
foreign import spliceSTArray
  :: forall a h r
   . STArray h a
  -> Int
  -> Int
  -> Array a
  -> Eff (st :: ST h | r) (Array a)

-- | Create an immutable copy of a mutable array, where each element
-- | is labelled with its index in the original array.
foreign import toAssocArray
  :: forall a h r
   . STArray h a
  -> Eff (st :: ST h | r) (Array (Assoc a))


this looks nicer

this looks nicer

module Views.Channel where

import Data.Array

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Models.Action
import Models.Channel

channelView :: T.Context Models.State.State Unit Models.Action.Action -> Channel -> Thermite.Types.Html Models.Action.Action
channelView ctx channel =
	E.li [ A.className "channel" ]
		[ E.span
			[ A.className "channel-name"
			, T.onClick ctx (const $ SelectChannel channel)
			]
			[ H.text channel.name ]
		]

channelsView :: T.Context Models.State.State Unit Models.Action.Action -> [Channel] -> Thermite.Types.Html Models.Action.Action
channelsView ctx channels =
	E.div [ A.className "channels" ]
		[ E.h2' [ H.text "Channels" ]
		, E.ul [ A.className "channels-list" ] ((channelView ctx) <$> channels)
		]

module Views.Channel where

import Data.Array

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Models.Action
import Models.Channel

channelView :: T.Context Models.State.State Unit Models.Action.Action -> Channel -> Thermite.Types.Html Models.Action.Action
channelView ctx channel@{ name: name } =
	E.li [ A.className "channel" ]
		[ E.span
			[ A.className "channel-name"
			, T.onClick ctx (const $ SelectChannel channel)
			]
			[ H.text name ]
		]

channelsView :: T.Context Models.State.State Unit Models.Action.Action -> [Channel] -> Thermite.Types.Html Models.Action.Action
channelsView ctx channels =
	E.div [ A.className "channels" ]
		[ E.h2' [ H.text "Channels" ]
		, E.ul [ A.className "channels-list" ] ((channelView ctx) <$> channels)
		]


Decode correctly the input

Decode correctly the input

module State where

import Prelude
import Types
import Data.Array
import Data.Lens
import Data.Lens.Index
import Data.Lens.Setter
import Data.Array
import Data.Maybe
import Data.Argonaut
import Control.Monad.Aff
import Control.Monad.Eff
import WebSocket
import Data.String as S
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Var (($=))
import Data.Either
import Data.Lens.Traversal (traversed)
import Pux (noEffects)
import Signal.Channel (send, Channel)

initialNotebook :: Notebook
initialNotebook = Notebook
  { title: ""
  , subtitle: ""
  , author: ""
  , date: ""
  , cells: [] :: Array Cell
  }

decodeReceived :: String -> Json
decodeReceived s = case jsonParser s of
    Right j -> j
    Left _ -> fromString ""

initialAppState :: Channel Action -> String -> forall e. Eff (err::EXCEPTION, ws::WEBSOCKET|e) AppState
initialAppState chan url = do
    connection@(Connection ws) <- newWebSocket (URL url) []
    ws.onopen $= \event -> do
        ws.send (Message "Hi! I am client")
    ws.onmessage $= \event -> do
        let received = runMessage (runMessageEvent event)
        let nb = decodeJson (decodeReceived received) :: Either String Notebook
        case nb of
            Left s ->
                send chan (NoOp :: Action)
            Right n ->
                send chan ((UpdateNotebook n) :: Action)
    pure $ AppState
        { editing: true
        , notebook: initialNotebook
        , totalCells: 0
        , currentCell: 0
        , socket : connection
        }

appendCell :: Cell -> AppState -> AppState
appendCell c =
  ((_notebook <<< _cells ) <>~ [c]) <<< (_totalCells +~ 1)

addTextCell :: AppState -> AppState
addTextCell as = appendCell (Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: TextCell} ) as

addCodeCell :: AppState -> AppState
addCodeCell as = appendCell emptyCodeCell as
  where
    emptyCodeCell = Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: CodeCell }

addDisplayCell :: String -> AppState -> AppState
addDisplayCell msg as = appendCell displayCell as
  where
    displayCell = Cell { cellId : (getTotalCells as), cellContent: msg, cellType: DisplayCell }

getTotalCells :: AppState -> Int
getTotalCells = view _totalCells

updateNotebook :: Notebook -> AppState -> AppState
updateNotebook n (AppState as) = AppState $ as { notebook = n }

updateCell :: Int -> String -> AppState -> AppState
updateCell i s =
  over (_notebook <<< _cells) (\x -> map updateCell' x)
  where
    isCorrectCell (Cell c) = c.cellId == i
    updateCell' (Cell c) = if isCorrectCell (Cell c) then Cell c { cellContent = s } else Cell c

update :: Action -> AppState -> EffModel AppState Action (ws :: WEBSOCKET)
update ToggleEdit appState  = noEffects $ appState
update AddTextCell appState = noEffects $ addTextCell appState
update AddCodeCell appState = noEffects $ addCodeCell appState
update (RenderCodeCell i) appState =
  { state: appState
  , effects: [ do
      pure NoOp
    ]
  }
update (CheckInput i ev) appState = noEffects $ updateCell i ev.target.value appState
update CheckNotebook as@(AppState appState) =
    { state: as
    , effects: [ do
        liftEff $ checkNotebook appState.socket appState.notebook
      ]
    }
update (UpdateNotebook receivedNotebook) appState = noEffects $ updateNotebook receivedNotebook appState
update NoOp appState = noEffects $ appState

checkNotebook :: forall eff . Connection -> Notebook -> Eff ( ws :: WEBSOCKET, err :: EXCEPTION | eff ) Action
checkNotebook (Connection ws) n = do
    let s = encodeJson n
    ws.send (Message $ show s) *> pure NoOp

module State where

import Prelude
import Types
import Data.Array
import Data.Lens
import Data.Lens.Index
import Data.Lens.Setter
import Data.Array
import Data.Maybe
import Data.Argonaut
import Control.Monad.Aff
import Control.Monad.Eff
import WebSocket
import Data.String as S
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Var (($=))
import Data.Either
import Data.Lens.Traversal (traversed)
import Pux (noEffects)
import Signal.Channel (send, Channel)

initialNotebook :: Notebook
initialNotebook = Notebook
  { title: ""
  , subtitle: ""
  , author: ""
  , date: ""
  , cells: [] :: Array Cell
  }

initialAppState :: Channel Action -> String -> forall e. Eff (err::EXCEPTION, ws::WEBSOCKET|e) AppState
initialAppState chan url = do
    connection@(Connection ws) <- newWebSocket (URL url) []
    ws.onopen $= \event -> do
        ws.send (Message "Hi! I am client")
    ws.onmessage $= \event -> do
        let received = runMessage (runMessageEvent event)
        let nb = decodeJson (fromString received) :: Either String Notebook
        case nb of
            Left s ->
                send chan (NoOp :: Action)
            Right n ->
                send chan ((UpdateNotebook n) :: Action)
    pure $ AppState
        { editing: true
        , notebook: initialNotebook
        , totalCells: 0
        , currentCell: 0
        , socket : connection
        }

appendCell :: Cell -> AppState -> AppState
appendCell c =
  ((_notebook <<< _cells ) <>~ [c]) <<< (_totalCells +~ 1)

addTextCell :: AppState -> AppState
addTextCell as = appendCell (Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: TextCell} ) as

addCodeCell :: AppState -> AppState
addCodeCell as = appendCell emptyCodeCell as
  where
    emptyCodeCell = Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: CodeCell }

addDisplayCell :: String -> AppState -> AppState
addDisplayCell msg as = appendCell displayCell as
  where
    displayCell = Cell { cellId : (getTotalCells as), cellContent: msg, cellType: DisplayCell }

getTotalCells :: AppState -> Int
getTotalCells = view _totalCells

updateNotebook :: Notebook -> AppState -> AppState
updateNotebook n (AppState as) = AppState $ as { notebook = n }

updateCell :: Int -> String -> AppState -> AppState
updateCell i s =
  over (_notebook <<< _cells) (\x -> map updateCell' x)
  where
    isCorrectCell (Cell c) = c.cellId == i
    updateCell' (Cell c) = if isCorrectCell (Cell c) then Cell c { cellContent = s } else Cell c

update :: Action -> AppState -> EffModel AppState Action (ws :: WEBSOCKET)
update ToggleEdit appState  = noEffects $ appState
update AddTextCell appState = noEffects $ addTextCell appState
update AddCodeCell appState = noEffects $ addCodeCell appState
update (RenderCodeCell i) appState =
  { state: appState
  , effects: [ do
      pure NoOp
    ]
  }
update (CheckInput i ev) appState = noEffects $ updateCell i ev.target.value appState
update CheckNotebook as@(AppState appState) =
    { state: as
    , effects: [ do
        liftEff $ checkNotebook appState.socket appState.notebook
      ]
    }
update (UpdateNotebook receivedNotebook) appState = noEffects $ updateNotebook receivedNotebook appState
update NoOp appState = noEffects $ appState

checkNotebook :: forall eff . Connection -> Notebook -> Eff ( ws :: WEBSOCKET, err :: EXCEPTION | eff ) Action
checkNotebook (Connection ws) n = do
    let s = encodeJson n
    ws.send (Message $ show s) *> pure NoOp


Added initial randomisation

Added initial randomisation

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff, liftEff')
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip, head, take, uncons)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), Event(..), State)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div, img)
import Text.Smolder.HTML.Attributes (className, src, alt)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (random ∷ RANDOM, ajax ∷ AJAX | e) (Maybe Countries)
fetch = get "/countries.json" >>= \xs → case decode xs of
          Left _          → pure $ Nothing
          Right countries → do
            shuffled <- liftEff (shuffle countries)
            pure $ Just shuffled

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Request)           state = onlyEffects state [Just <<< Receive <$> fetch]
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Respond name)      state = noEffects $ case join $ uncons <$> state.countries of
  Nothing                              → state { countries = Nothing }
  Just { head: (Country x), tail: xs } → case name == x.name of
    true  → state { countries = Just xs, correct = state.correct + 1 }
    false → state { countries = Just xs, incorrect = state.incorrect + 1 }

view ∷ State → HTML Event
view state = div ! className "flagship" $ do
  ul ! className "header" $ do
    li $ h1 $ text "Flagship"
    li $ button #! onClick (const Request) $ text "Start"
    li ! className "score correct" $ text $ show state.correct
    li ! className "score incorrect" $ text $ show state.incorrect
    li ! className "score" $ text $ show $ state.correct + state.incorrect
  <> do div ! className "prompt" $ case state.countries of
          Nothing        → button #! onClick (const Request) $ text "Start"
          Just countries → case head countries of
            Nothing              → div $ text "All done!"
            Just (Country current) → do
              img ! src ("images/flags/" <> current.flag) ! alt "Flag"
              ul ! className "countries" $ for_ (take 4 countries) $ \(Country answer) →
                li $ button #! onClick (const $ Respond answer.name) $ text answer.name

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff, liftEff')
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip, head, take, uncons)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), Event(..), State)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div, img)
import Text.Smolder.HTML.Attributes (className, src, alt)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (random ∷ RANDOM, ajax ∷ AJAX | e) (Maybe Countries)
fetch = get "/countries.json" >>= \xs → case decode xs of
          Left _          → pure $ Nothing
          Right countries → pure $ Just countries

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Request)           state = onlyEffects state [Just <<< Receive <$> fetch]
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Respond name)      state = noEffects $ case join $ uncons <$> state.countries of
  Nothing                              → state { countries = Nothing }
  Just { head: (Country x), tail: xs } → case name == x.name of
    true  → state { countries = Just xs, correct = state.correct + 1 }
    false → state { countries = Just xs, incorrect = state.incorrect + 1 }

view ∷ State → HTML Event
view state = div ! className "flagship" $ do
  ul ! className "header" $ do
    li $ h1 $ text "Flagship"
    li $ button #! onClick (const Request) $ text "Start"
    li ! className "score correct" $ text $ show state.correct
    li ! className "score incorrect" $ text $ show state.incorrect
    li ! className "score" $ text $ show $ state.correct + state.incorrect
  <> do div ! className "prompt" $ case state.countries of
          Nothing        → button #! onClick (const Request) $ text "Start"
          Just countries → case head countries of
            Nothing              → div $ text "All done!"
            Just (Country current) → do
              img ! src ("images/flags/" <> current.flag) ! alt "Flag"
              ul ! className "countries" $ for_ (take 4 countries) $ \(Country answer) →
                li $ button #! onClick (const $ Respond answer.name) $ text answer.name


clean up more code

clean up more code

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      liftEff $ runServer options {} (router {dir, db})
  where
    router ctx = getConn :>>= handleConn ctx
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< readdir path
          pure $ fst <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = sortBy compareDates
        compareDates (Tuple _ a) (Tuple _ b) =
          compare EQ $ compare (modifiedTime a) (modifiedTime b)
    handleConn {dir, db} conn =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> files
        Tuple (Left GET) "/api/watched" -> watched
        Tuple (Left POST) "/api/update" -> update
        Tuple (Left POST) "/api/open" -> open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          files = readFiles dir :>>= respondJSON
          queryDB' q p = lift' $ queryDB db q p
          open = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (OpenRequest or) -> do
                _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
                respondJSON "{}"
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          update = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (UpdateRequest ur) -> do
                _ <- if ur.watched
                  then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
                  else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
                watched
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (reverse, sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff do
  e <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case e of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      liftEff $ runServer options {} (router {dir, db})
  where
    router ctx = getConn :>>= handleConn ctx
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< readdir path
          pure $ extractStat <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = reverse <<< sortBy compareDates
        compareDates (Tuple _ a) (Tuple _ b) =
          compare (modifiedTime a) (modifiedTime b)
        extractStat (Tuple file _) = file
    handleConn {dir, db} conn =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> do
          files <- readFiles dir
          respondJSON files
        Tuple (Left GET) "/api/watched" -> do
          watched
        Tuple (Left POST) "/api/update" -> do
          update
        Tuple (Left POST) "/api/open" -> do
          open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          queryDB' q p = lift' $ queryDB db q p
          open = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (OpenRequest or) -> do
                _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
                respondJSON "{}"
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          update = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (UpdateRequest ur) -> do
                _ <- if ur.watched
                  then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
                  else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
                watched
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a


[CSE-60] Fix test

[CSE-60] Fix test

module Explorer.Util.Time.Test where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Identity (Identity)
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Days(Days), Milliseconds(Milliseconds), Minutes(Minutes), Seconds(Seconds))
import Data.Time.NominalDiffTime (mkTime)
import Explorer.I18n.Lang (Language(..))
import Explorer.Util.Time (prettyDuration, prettyDate)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testPrettyDuration :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testPrettyDuration =
    describe "Explorer.Util.Time.Test" do
        describe "prettyDuration" do
            describe "short durations" do
                it "a milisecond should return less than a minute" do
                  let result = prettyDuration English (Milliseconds 1.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
                it "a second should return less than a minute" do
                  let result = prettyDuration English (Seconds 1.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
                it "59 seconds should return less than a minute" do
                  let result = prettyDuration English (Seconds 59.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
            describe "durations" do
                it "30 minutes should return 30 minutes" do
                    let result = prettyDuration English (Minutes 30.0)
                        expected = "30 Minutes"
                    result `shouldEqual` expected
            describe "longer durations" do
              it "5 days should return 5 days" do
                  let result = prettyDuration English (Days 5.0)
                      expected = "5 Days"
                  result `shouldEqual` expected
        describe "prettyDate" do
              it "format date of DD.MM.YYYY HH:mm,ss" do
                  let result =  prettyDate "DD.MM.YYYY HH:mm,ss" $ mkTime 1490098347.0
                  "21.03.2017 12:12,27" `shouldEqual` fromMaybe "failed" result
              it "format date of MM/DD/YYYY HH:mm,ss" do
                  let result =  prettyDate "DD.MM.YYYY HH:mm.ss" $ mkTime 1490098689.0
                  "21.03.2017 12:18.09" `shouldEqual` fromMaybe "failed" result

module Explorer.Util.Time.Test where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Identity (Identity)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Time.Duration (Days(Days), Milliseconds(Milliseconds), Minutes(Minutes), Seconds(Seconds))
import Data.Time.NominalDiffTime (mkTime)
import Explorer.I18n.Lang (Language(..))
import Explorer.Util.Time (prettyDuration, nominalDiffTimeToDateTime, prettyDate)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testPrettyDuration :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testPrettyDuration =
    describe "Explorer.Util.Time.Test" do
        describe "prettyDuration" do
            describe "short durations" do
                it "a milisecond should return less than a minute" do
                  let result = prettyDuration English (Milliseconds 1.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
                it "a second should return less than a minute" do
                  let result = prettyDuration English (Seconds 1.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
                it "59 seconds should return less than a minute" do
                  let result = prettyDuration English (Seconds 59.0)
                      expected = "< 1 Minutes"
                  result `shouldEqual` expected
            describe "durations" do
                it "30 minutes should return 30 minutes" do
                    let result = prettyDuration English (Minutes 30.0)
                        expected = "30 Minutes"
                    result `shouldEqual` expected
            describe "longer durations" do
              it "5 days should return 5 days" do
                  let result = prettyDuration English (Days 5.0)
                      expected = "5 Days"
                  result `shouldEqual` expected
        describe "prettyDate" do
              it "format date of DD.MM.YYYY HH:mm,ss" do
                  let result =  prettyDate "DD.MM.YYYY HH:mm,ss" $ mkTime 1490098347.0
                  "21.03.2017 12:12,27" `shouldEqual` fromMaybe "failed" result
              it "format date of MM/DD/YYYY HH:mm,ss" do
                  let result =  prettyDate "DD.MM.YYYY HH:mm.ss" $ mkTime 1490098689.0
                  "21.03.2017 12:18.9" `shouldEqual` fromMaybe "failed" result


Delete pending tests :refactoring:

Delete pending tests :refactoring:

module Test.DataSnapshotSpec (dataSnapshotSpec) where

import Prelude (Unit, bind, ($), (>>=), (>=))

import Node.Process (PROCESS)
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad (unless)
import Data.Maybe (Maybe(Just))
import Web.Firebase as FB
import Web.Firebase.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (fail, shouldEqual)

eSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
eSnapshot = snapshotFor "entries"

doesNotExist :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
doesNotExist = snapshotFor "entries/doesnotexist"

snapshotFor :: forall eff. String -> Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
snapshotFor location  = getRoot >>= \r -> (liftEff $ FB.child location r) >>= onceValue

getRoot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
getRoot = refFor "https://purescript-spike.firebaseio.com/"

expect :: forall r. Boolean -> Aff r Unit
expect condition = unless condition $ fail "false ≠ true"

dataSnapshotSpec ::  forall eff. FBT.DataSnapshot -> Spec ( process :: PROCESS, firebase :: FBT.FirebaseEff | eff) Unit
dataSnapshotSpec snapshot =
    describe "DataSnapshot" do
      -- literal API
      -- the difference between snapshots and refs is somewhat confusing
      it "can tell us the number of children" do
        let numChildren = D.numChildren snapshot
        expect (numChildren >= 1)

      it "can tell us a child does not exist" do
        (D.hasChild snapshot "doesnotexist")  `shouldEqual` false
      it "can tell us the location at the snapshot exists" do
        expect $ (D.exists snapshot)

      it "can tell us it has children" do
        expect $ D.hasChildren snapshot

      it "says the key of /entries is entries" do
        let key = D.key snapshot
        key `shouldEqual` (Just "entries")

      it "it can not tell us the location at the snapshot does not exist" do
        let noChild = (D.child snapshot "doesnotexist")
        (D.exists noChild) `shouldEqual` false

module Test.DataSnapshotSpec (dataSnapshotSpec) where

import Prelude (Unit, bind, ($), (>>=), (>=))

import Node.Process (PROCESS)
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad (unless)
import Data.Maybe (Maybe(Just))
import Web.Firebase as FB
import Web.Firebase.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, pending, it, Spec())
import Test.Spec.Assertions       (fail, shouldEqual)

eSnapshot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
eSnapshot = snapshotFor "entries"

doesNotExist :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
doesNotExist = snapshotFor "entries/doesnotexist"

snapshotFor :: forall eff. String -> Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
snapshotFor location  = getRoot >>= \r -> (liftEff $ FB.child location r) >>= onceValue

getRoot :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
getRoot = refFor "https://purescript-spike.firebaseio.com/"

expect :: forall r. Boolean -> Aff r Unit
expect condition = unless condition $ fail "false ≠ true"

dataSnapshotSpec ::  forall eff. FBT.DataSnapshot -> Spec ( process :: PROCESS, firebase :: FBT.FirebaseEff | eff) Unit
dataSnapshotSpec snapshot =
    describe "DataSnapshot" do
      -- literal API
      -- the difference between snapshots and refs is somewhat confusing
      it "can tell us the number of children" do
        let numChildren = D.numChildren snapshot
        expect (numChildren >= 1)
      pending "can list the keys of its children by using forEach"

      it "can tell us a child does not exist" do
        (D.hasChild snapshot "doesnotexist")  `shouldEqual` false
      pending "relying on a fixed existing child is too fragile"
      pending "it can tell us a child exists"
      pending "it can give us a snapshot of one of its children"
{-
      it "can tell us a child exists" do
        - use foreach instead. perhaps create list like interface in Web.Firebase.Extra.DataSnapshotList
        expect $ D.hasChild snapshot "-K7GbWeFHfJXlun7szRe"

      it "can give us a snapshot of one of its children" do
        let c = D.child snapshot "-K7GbWeFHfJXlun7szRe"
        expect $ D.exists c
-}
      it "can tell us the location at the snapshot exists" do
        expect $ (D.exists snapshot)

      it "can tell us it has children" do
        expect $ D.hasChildren snapshot

      pending "says the key of the database root is Nothing" {-
        -- Root has become inacessible due to permission tests :-( not sure how to test Nothing for key now
        do
        rs <- rootSnapshot
        let key = D.key rs
        key `shouldEqual` Nothing
      -}
      it "says the key of /entries is entries" do
        let key = D.key snapshot
        key `shouldEqual` (Just "entries")

      it "it can not tell us the location at the snapshot does not exist" do
        let noChild = (D.child snapshot "doesnotexist")
        (D.exists noChild) `shouldEqual` false
        -- /entries/doesnotexist
        -- perhaps it can now, it might just have been an error callback with an additional () missing.
      pending "can it say the value of child \"entries\" is Nothing?"
        -- this relies on trying to read a firebase ref with once, and that 'works' by never being called back


Add more test cases for array and object literals

module Test.PureSwift.CodeGen
  ( testCodeGen
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import CoreFn.Expr (Bind(..), Expr(..), Literal(..))
import CoreFn.Ident (Ident(..))
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import PureSwift.CodeGen (Swift(..), moduleToSwift)
import Test.Assert (ASSERT, assert')

testCodeGen :: forall e. Eff (assert :: ASSERT, console :: CONSOLE | e) Unit
testCodeGen = do
  log ""
  log "Test CodeGen"

  testExports
  testHelloWorld
  testLiterals

  where

  test
    :: String
    -> Module Unit
    -> Swift
    -> Eff (assert :: ASSERT, console :: CONSOLE | e) Unit
  test description mod swift = do
    log $ "  " <> description
    let actual = unwrap (moduleToSwift mod)
    let expected = unwrap swift

    let message = "\n" <>
      "\n" <>
      "  Actual:" <> "\n" <>
      actual <> "\n" <>
      "  Expected:" <> "\n" <>
      expected <> "\n"

    assert' message $ actual == expected

  testExports = do
    let exported = Literal unit $ StringLiteral "exported"
    let notExported = Literal unit $ StringLiteral "not exported"

    let builtWith = "0.10.1"

    let moduleDecls = [ NonRec unit (Ident "exported") exported
                      , NonRec unit (Ident "notExported") notExported
                      ]

    let moduleExports = [ Ident "exported" ]

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim" ]

    let moduleName = ModuleName "Exports"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Exports" mod $ Swift $ "" <>
"""// Exports
// Built with PureScript 0.10.1

public let exported = "exported"
let notExported = "not exported"
"""

  testHelloWorld = do
    let declIdent = Ident "main"
    let declModuleName = Just (ModuleName "Control.Monad.Eff.Console")
    let declQualifier = Qualified declModuleName (Ident "log")
    let declVar = Var unit declQualifier
    let declLiteral = Literal unit $ StringLiteral "Hello world!"

    let declExpr = App unit declVar declLiteral
    let decl = NonRec unit declIdent declExpr

    let builtWith = "0.10.1"

    let moduleDecls = [ decl ]

    let moduleExports = [ Ident "main"
                        ]

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim"
                        , ModuleName "Prelude"
                        , ModuleName "Control.Monad.Eff"
                        , ModuleName "Control.Monad.Eff.Console"
                        ]

    let moduleName = ModuleName "Main"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Hello World" mod $ Swift $ "" <>
"""// Main
// Built with PureScript 0.10.1

import Prelude
import Control_Monad_Eff
import Control_Monad_Eff_Console

public func main() -> () {
  Control_Monad_Eff_Console.log("Hello world!")
}
"""

  testLiterals = do
    let intLiteral = Literal unit $ NumericLiteral (Left 42)
    let numberLiteral = Literal unit $ NumericLiteral (Right 3.14)
    let stringLiteral = Literal unit $ StringLiteral "Hello world!"
    let charLiteral = Literal unit $ CharLiteral 'a'
    let booleanLiteral = Literal unit $ BooleanLiteral true

    let arrayLiteral = Literal unit $ ArrayLiteral [ Literal unit $ NumericLiteral (Left 1)
                                                   , Literal unit $ NumericLiteral (Left 2)
                                                   , Literal unit $ NumericLiteral (Left 3)
                                                   ]

    let emptyArrayLiteral = Literal unit $ ArrayLiteral []

    let singleItemArrayLiteral = Literal unit $ ArrayLiteral [ Literal unit $ NumericLiteral (Left 1)
                                                             ]

    let objectLiteral = Literal unit $ ObjectLiteral [ Tuple "a" (Literal unit $ NumericLiteral (Left 1))
                                                     , Tuple "b" (Literal unit $ NumericLiteral (Left 2))
                                                     , Tuple "c" (Literal unit $ NumericLiteral (Left 3))
                                                     ]

    let emptyObjectLiteral = Literal unit $ ObjectLiteral []

    let singleItemObjectLiteral = Literal unit $ ObjectLiteral [ Tuple "a" (Literal unit $ NumericLiteral (Left 1))
                                                     ]

    let builtWith = "0.10.1"

    let moduleDecls = [ NonRec unit (Ident "int") intLiteral
                      , NonRec unit (Ident "number") numberLiteral
                      , NonRec unit (Ident "string") stringLiteral
                      , NonRec unit (Ident "char") charLiteral
                      , NonRec unit (Ident "boolean") booleanLiteral
                      , NonRec unit (Ident "array") arrayLiteral
                      , NonRec unit (Ident "emptyArray") emptyArrayLiteral
                      , NonRec unit (Ident "singleItemArray") singleItemArrayLiteral
                      , NonRec unit (Ident "object") objectLiteral
                      , NonRec unit (Ident "emptyObject") emptyObjectLiteral
                      , NonRec unit (Ident "singleItemObject") singleItemObjectLiteral
                      ]

    let moduleExports = []

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim" ]

    let moduleName = ModuleName "Literals"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Literals" mod $ Swift $ "" <>
"""// Literals
// Built with PureScript 0.10.1

let int = 42
let number = 3.14
let string = "Hello world!"
let char = "a"
let boolean = true
let array = [ 1, 2, 3 ]
let emptyArray = []
let singleItemArray = [ 1 ]
let object = { a: 1, b: 2, c: 3 }
let emptyObject = {}
let singleItemObject = { a: 1 }
"""

module Test.PureSwift.CodeGen
  ( testCodeGen
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import CoreFn.Expr (Bind(..), Expr(..), Literal(..))
import CoreFn.Ident (Ident(..))
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import PureSwift.CodeGen (Swift(..), moduleToSwift)
import Test.Assert (ASSERT, assert')

testCodeGen :: forall e. Eff (assert :: ASSERT, console :: CONSOLE | e) Unit
testCodeGen = do
  log ""
  log "Test CodeGen"

  testExports
  testHelloWorld
  testLiterals

  where

  test
    :: String
    -> Module Unit
    -> Swift
    -> Eff (assert :: ASSERT, console :: CONSOLE | e) Unit
  test description mod swift = do
    log $ "  " <> description
    let actual = unwrap (moduleToSwift mod)
    let expected = unwrap swift

    let message = "\n" <>
      "\n" <>
      "  Actual:" <> "\n" <>
      actual <> "\n" <>
      "  Expected:" <> "\n" <>
      expected <> "\n"

    assert' message $ actual == expected

  testExports = do
    let exported = Literal unit $ StringLiteral "exported"
    let notExported = Literal unit $ StringLiteral "not exported"

    let builtWith = "0.10.1"

    let moduleDecls = [ NonRec unit (Ident "exported") exported
                      , NonRec unit (Ident "notExported") notExported
                      ]

    let moduleExports = [ Ident "exported" ]

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim" ]

    let moduleName = ModuleName "Exports"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Exports" mod $ Swift $ "" <>
"""// Exports
// Built with PureScript 0.10.1

public let exported = "exported"
let notExported = "not exported"
"""

  testHelloWorld = do
    let declIdent = Ident "main"
    let declModuleName = Just (ModuleName "Control.Monad.Eff.Console")
    let declQualifier = Qualified declModuleName (Ident "log")
    let declVar = Var unit declQualifier
    let declLiteral = Literal unit $ StringLiteral "Hello world!"

    let declExpr = App unit declVar declLiteral
    let decl = NonRec unit declIdent declExpr

    let builtWith = "0.10.1"

    let moduleDecls = [ decl ]

    let moduleExports = [ Ident "main"
                        ]

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim"
                        , ModuleName "Prelude"
                        , ModuleName "Control.Monad.Eff"
                        , ModuleName "Control.Monad.Eff.Console"
                        ]

    let moduleName = ModuleName "Main"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Hello World" mod $ Swift $ "" <>
"""// Main
// Built with PureScript 0.10.1

import Prelude
import Control_Monad_Eff
import Control_Monad_Eff_Console

public func main() -> () {
  Control_Monad_Eff_Console.log("Hello world!")
}
"""

  testLiterals = do
    let intLiteral = Literal unit $ NumericLiteral (Left 42)
    let numberLiteral = Literal unit $ NumericLiteral (Right 3.14)
    let stringLiteral = Literal unit $ StringLiteral "Hello world!"
    let charLiteral = Literal unit $ CharLiteral 'a'
    let booleanLiteral = Literal unit $ BooleanLiteral true
    let arrayLiteral = Literal unit $ ArrayLiteral [ Literal unit $ NumericLiteral (Left 1)
                                                   , Literal unit $ NumericLiteral (Left 2)
                                                   , Literal unit $ NumericLiteral (Left 3)
                                                   ]
    let objectLiteral = Literal unit $ ObjectLiteral [ Tuple "a" (Literal unit $ NumericLiteral (Left 1))
                                                     , Tuple "b" (Literal unit $ NumericLiteral (Left 2))
                                                     , Tuple "c" (Literal unit $ NumericLiteral (Left 3))
                                                     ]

    let builtWith = "0.10.1"

    let moduleDecls = [ NonRec unit (Ident "int") intLiteral
                      , NonRec unit (Ident "number") numberLiteral
                      , NonRec unit (Ident "string") stringLiteral
                      , NonRec unit (Ident "char") charLiteral
                      , NonRec unit (Ident "boolean") booleanLiteral
                      , NonRec unit (Ident "array") arrayLiteral
                      , NonRec unit (Ident "object") objectLiteral
                      ]

    let moduleExports = [ Ident "int"
                        , Ident "number"
                        , Ident "string"
                        , Ident "char"
                        , Ident "boolean"
                        , Ident "array"
                        , Ident "object"
                        ]

    let moduleForeign = []

    let moduleImports = [ ModuleName "Prim" ]

    let moduleName = ModuleName "Literals"

    let mod = Module { builtWith
                     , moduleDecls
                     , moduleExports
                     , moduleForeign
                     , moduleImports
                     , moduleName
                     }

    test "Literals" mod $ Swift $ "" <>
"""// Literals
// Built with PureScript 0.10.1

public let int = 42
public let number = 3.14
public let string = "Hello world!"
public let char = "a"
public let boolean = true
public let array = [ 1, 2, 3 ]
public let object = { a: 1, b: 2, c: 3 }
"""


comment

comment

-- | Main app handler
module Controller.Request where

import Control.Monad.Eff
import Data.Maybe
import Data.Tuple
import Data.Either
import Debug.Trace
import Data.Foldable

import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf
import qualified Data.Array as A
import qualified Halogen as Hl
import qualified Control.Timer as Tm
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Text.SlamSearch as S
import qualified Routing.Hash as Rh
import qualified Data.String as Str
import qualified Data.DOM.Simple.Element as El
import qualified Controller.Driver as Cd

import qualified Model as M
import qualified Api.Fs as Api

handler :: forall e. M.Request ->
           Aff.Aff (Hl.HalogenEffects (timer::Tm.Timer|e)) M.Input
handler r = Aff.makeAff $ \_ k -> do
  case r of
    -- value of search has been changed
    M.SearchChange mbTimeout ch -> do
      k $ M.SearchNextValue ch
      maybe (pure unit) Tm.clearTimeout mbTimeout
      tim <- Tm.timeout Config.searchTimeout $ setQ k ch
      k $ M.SearchTimeout tim
      k $ M.SearchValidation true

    -- pressed button or enter in search's input
    M.SearchSubmit s -> do
      maybe (pure unit) Tm.clearTimeout s.timeout
      setQ k s.nextValue

    -- sets sort
    M.SetSort sort -> do
      Rh.modifyHash $ Cd.updateSort sort

    -- opens item
    M.Open item -> do
      case item.resource of
        M.Directory ->
          moveDown item
        M.Database ->
          moveDown item
        M.File ->
          open item true
        M.Table ->
          open item true
        M.Notebook -> do
          open item false

    -- move/rename item
    M.Move _ ->
      U.log "move/rename"

    -- clicked on breadcrumb
    M.Breadcrumb b -> do
      Rh.modifyHash $ Cd.updatePath b.link

    -- clicked on _File_ link triggering file uploading
    M.UploadFile node _ -> do
      let el = U.convertToElement node
      mbInput <- El.querySelector "input" el
      case mbInput of
        Nothing -> pure unit
        Just input -> do
          void $ Ue.raiseEvent "click" input {}

    -- clicked on _Folder_ link, create phantom folder
    M.CreateFolder state -> do
      let name = getNewName Config.newFolderName state
      path <- Cd.getPath <$> U.currentHash
      k $ M.ItemAdd $ M.initDirectory{root = path, name = name}
      k $ M.Resort

    M.MountDatabase _ ->
      U.log "mount database"

    M.CreateNotebook state -> do
      let name = getNewName Config.newNotebookName state
      path <- Cd.getPath <$> U.currentHash
      let notebook = M.initNotebook{root = path, name = name}
      k $ M.ItemAdd notebook
      k $ M.Resort
      Api.makeNotebook (path <> name) M.newNotebook $ \success -> do
        if success then
          k M.Resort
          else
          k $ M.Remove notebook

    M.Delete item -> do
      Api.deleteItem item $ \success ->
        if success then do
          k $ M.Remove item
          k $ M.Resort
         else
          pure unit

    M.Share _ -> do
      U.log "share"

    -- configure db
    M.Configure _ -> do
      U.log "configure"

    -- triggered when files changed in file selecting dialog
    M.FileListChanged node state -> do
      let el = U.convertToElement node
      fileArr <- Uf.fileListToArray <$> Uf.files el
      Uf.clearValue el
      case A.head fileArr of
        Nothing -> pure unit
        Just file -> void $ do
          reader <- Uf.newReader
          Uf.readAsBinaryString file reader
          Uf.onload reader $ do
            cont <- Uf.result reader
            case cont of
              Nothing -> pure unit
              Just res -> do
                path <- Cd.getPath <$> U.currentHash
                name <- flip getNewName state <$> Uf.name file
                Api.makeFile (path <> name) res \success -> do
                  k $ M.ItemAdd $ M.initFile{root = path, name = name}
                  k $ M.Resort

        -- set `q` in route
  where setQ k q =
          case S.mkQuery q of
            Left _ | q /= "" -> k $ M.SearchValidation false
            Right _ -> do
              Rh.modifyHash $ Cd.updateQ q
              k $ M.SearchValidation true
            _ -> do
              Rh.modifyHash $ Cd.updateQ ""
              k $ M.SearchValidation true
        -- open dir or db
        moveDown item = Rh.modifyHash $ Cd.addToPath item.name
        -- open notebook or file
        open item isNew = U.newTab $ foldl (<>) ""
                          ([Config.notebookUrl,
                            "#", item.root, item.name] <>
                             if isNew then
                             ["/?q=", U.encodeURIComponent ("select * from ...")]
                           else [])
        -- get fresh name for this state
        getNewName :: String -> M.State -> String
        getNewName name state =
          if A.findIndex (\x -> x.name == name) state.items /= -1 then
            getNewName' name 1
            else name
          where getNewName' name i =
                  -- Str.split and Str.joinWith work with []
                  -- converting from/to List will be too expensive
                  case Str.split "." name of
                    [] -> ""
                    body:suffixes ->
                      let newName = Str.joinWith "." $ (body <> show i):suffixes
                      in if A.findIndex
                            (\x -> x.name == newName)
                            state.items /= -1
                         then getNewName' name (i + 1)
                         else newName

-- | Main app handler
module Controller.Request where

import Control.Monad.Eff
import Data.Maybe
import Data.Tuple
import Data.Either
import Debug.Trace
import Data.Foldable

import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf
import qualified Data.Array as A
import qualified Halogen as Hl
import qualified Control.Timer as Tm
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Text.SlamSearch as S
import qualified Routing.Hash as Rh
import qualified Data.String as Str
import qualified Data.DOM.Simple.Element as El
import qualified Controller.Driver as Cd

import qualified Model as M
import qualified Api.Fs as Api

handler :: forall e. M.Request ->
           Aff.Aff (Hl.HalogenEffects (timer::Tm.Timer|e)) M.Input
handler r = Aff.makeAff $ \_ k -> do
  case r of
    -- value of search has been changed
    M.SearchChange mbTimeout ch -> do
      k $ M.SearchNextValue ch
      maybe (pure unit) Tm.clearTimeout mbTimeout
      tim <- Tm.timeout Config.searchTimeout $ setQ k ch
      k $ M.SearchTimeout tim
      k $ M.SearchValidation true

    -- pressed button or enter in search's input
    M.SearchSubmit s -> do
      maybe (pure unit) Tm.clearTimeout s.timeout
      setQ k s.nextValue

    -- sets sort
    M.SetSort sort -> do
      Rh.modifyHash $ Cd.updateSort sort

    -- opens item
    M.Open item -> do
      case item.resource of
        M.Directory ->
          moveDown item
        M.Database ->
          moveDown item
        M.File ->
          open item true
        M.Table ->
          open item true
        M.Notebook -> do
          open item false

    -- move/rename item
    M.Move _ ->
      U.log "move/rename"

    -- clicked on breadcrumb
    M.Breadcrumb b -> do
      Rh.modifyHash $ Cd.updatePath b.link

    -- clicked on _File_ link triggering file uploading
    M.UploadFile node _ -> do
      let el = U.convertToElement node
      mbInput <- El.querySelector "input" el
      case mbInput of
        Nothing -> pure unit
        Just input -> do
          void $ Ue.raiseEvent "click" input {}

    -- clicked on _Folder_ link, create phantom folder
    M.CreateFolder state -> do
      let name = getNewName Config.newFolderName state
      path <- Cd.getPath <$> U.currentHash
      k $ M.ItemAdd $ M.initDirectory{root = path, name = name}
      k $ M.Resort

    M.MountDatabase _ ->
      U.log "mount database"

    M.CreateNotebook state -> do
      let name = getNewName Config.newNotebookName state
      path <- Cd.getPath <$> U.currentHash
      let notebook = M.initNotebook{root = path, name = name}
      k $ M.ItemAdd notebook
      k $ M.Resort
      Api.makeNotebook (path <> name) M.newNotebook $ \success -> do
        if success then
          k M.Resort
          else
          k $ M.Remove notebook

    M.Delete item -> do
      Api.deleteItem item $ \success ->
        if success then do
          k $ M.Remove item
          k $ M.Resort
         else
          pure unit

    M.Share _ -> do
      U.log "share"

    -- configure db
    M.Configure _ -> do
      U.log "configure"

    -- triggered when files changed in file selecting dialog
    M.FileListChanged node state -> do
      let el = U.convertToElement node
      fileArr <- Uf.fileListToArray <$> Uf.files el
      Uf.clearValue el
      case A.head fileArr of
        Nothing -> pure unit
        Just file -> void $ do
          reader <- Uf.newReader
          Uf.readAsBinaryString file reader
          Uf.onload reader $ do
            cont <- Uf.result reader
            case cont of
              Nothing -> pure unit
              Just res -> do
                path <- Cd.getPath <$> U.currentHash
                name <- flip getNewName state <$> Uf.name file
                Api.makeFile (path <> name) res \success -> do
                  k $ M.ItemAdd $ M.initFile{root = path, name = name}
                  k $ M.Resort

        -- set `q` in route
  where setQ k q =
          case S.mkQuery q of
            Left _ | q /= "" -> k $ M.SearchValidation false
            Right _ -> do
              Rh.modifyHash $ Cd.updateQ q
              k $ M.SearchValidation true
            _ -> do
              Rh.modifyHash $ Cd.updateQ ""
              k $ M.SearchValidation true
        -- open dir or db
        moveDown item = Rh.modifyHash $ Cd.addToPath item.name
        -- open notebook or file
        open item isNew = U.newTab $ foldl (<>) ""
                          ([Config.notebookUrl,
                            "#", item.root, item.name] <>
                             if isNew then
                             ["/?q=", U.encodeURIComponent ("select * from ...")]
                           else [])
        -- get fresh name for this state
        getNewName :: String -> M.State -> String
        getNewName name state =
          if A.findIndex (\x -> x.name == name) state.items /= -1 then
            getNewName' name 1
            else name
          where getNewName' name i =
                  case Str.split "." name of
                    [] -> ""
                    body:suffixes ->
                      let newName = Str.joinWith "." $ (body <> show i):suffixes
                      in if A.findIndex
                            (\x -> x.name == newName)
                            state.items /= -1
                         then getNewName' name (i + 1)
                         else newName