finish monad instance

finish monad instance

module D3HOAS.Selection where

import D3HOAS.Base (Selector)
import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, Unit, apply, bind, pure, unit, ($), ap)

data FakeSelection a = FakeSelection a -- could have EmptySelection here too?

instance functorFakeSelection :: Functor FakeSelection where
  map f (FakeSelection s) = FakeSelection $ f s

instance applyFakeSelection :: Apply FakeSelection where
  apply = ap

instance applicativeFakeSelection :: Applicative FakeSelection where
  pure a = FakeSelection a

instance bindFakeSelection :: Bind FakeSelection where
  bind (FakeSelection a) f = f a

instance monadFakeSelection :: Monad FakeSelection

class (Monad repr) <= Selection repr where
    d3Select    :: Selector -> repr Unit
    -- d3SelectAll :: Selector -> repr
    -- select      :: Selector -> repr -> repr
    -- selectAll   :: Selector -> repr -> repr
    -- merge       :: repr -> repr -> repr
    -- insert      :: D3ElementType -> repr -> repr
    -- append      :: D3ElementType -> repr -> repr
    -- remove      :: repr -> Unit
    -- enter       :: repr -> repr
    -- exit        :: repr -> repr
    -- transition  :: D3Transition -> repr -> repr
    -- attrs       :: ∀ d. Array (Attr d) -> repr -> repr
    -- dataA       :: ∀ d. Array d -> repr -> repr
    -- dataH       :: ∀ d. Array d -> repr -> repr
    -- dataAI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr
    -- dataHI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr

-- data DummySelection a = DS { d3Selection :: String }
--
-- instance selectionDummySelection :: Selection DummySelection where
--     d3Select selector = DS { d3Selection: selector }

module D3HOAS.Selection where

import Prelude (Unit)
import D3HOAS.Base

class Selection repr where
    d3Select    :: Selector -> repr
    -- d3SelectAll :: Selector -> repr
    -- select      :: Selector -> repr -> repr
    -- selectAll   :: Selector -> repr -> repr
    -- merge       :: repr -> repr -> repr
    -- insert      :: D3ElementType -> repr -> repr
    -- append      :: D3ElementType -> repr -> repr
    -- remove      :: repr -> Unit
    -- enter       :: repr -> repr
    -- exit        :: repr -> repr
    -- transition  :: D3Transition -> repr -> repr
    -- attrs       :: ∀ d. Array (Attr d) -> repr -> repr
    -- dataA       :: ∀ d. Array d -> repr -> repr
    -- dataH       :: ∀ d. Array d -> repr -> repr
    -- dataAI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr
    -- dataHI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr

data DummySelection = DS { d3Selection :: String }

instance selectionDummySelection :: Selection DummySelection where
    d3Select selector = DS { d3Selection: selector }


Simplified code by moving getCoordinateIndex to be inline

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
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
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == getCoordinate square

getCoordinate :: Square -> Coordinate
getCoordinate square = square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
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
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == getCoordinate square

getCoordinate :: Square -> Coordinate
getCoordinate square = square.coordinate

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (hasCoordinate coordinate)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Remove Semigroup Perm instance

Remove Semigroup Perm instance

If Semigroup is needed, Additive or Multiplicative can be used.

module Node.FS.Perms
  ( Perm()
  , none
  , read
  , write
  , execute
  , all
  , Perms()
  , mkPerms
  , permsFromString
  , permsToString
  , permsToInt
  ) where

import Global (readInt)
import Data.Array () -- for Semigroup and Functor instances
import Data.Maybe (Maybe(..))
import Data.Char (Char(), charString, fromCharCode)
import Data.String (toCharArray, joinWith, drop, charAt, indexOf)
import Data.Int (Int(), fromNumber, toNumber)

-- | A `Perm` value specifies what is allowed to be done with a particular
-- | file by a particular class of user — that is, whether it is
-- | readable, writable, and/or executable. It has a semigroup instance, which
-- | allows you to combine permissions; for example, `read <> write` means
-- | "readable and writable".
newtype Perm = Perm { r :: Boolean, w :: Boolean, x :: Boolean }

instance eqPerm :: Eq Perm where
  (==) (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    r1 == r2  && w1 == w2 && x1 == x2
  (/=) x y = not (x == y)

instance ordPerm :: Ord Perm where
  compare (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    compare [r1, w1, x1] [r2, w2, x2]

instance showPerm :: Show Perm where
  show p | p == none = "none"
  show p | p == all  = "all"
  show (Perm { r = r, w = w, x = x }) =
    joinWith " <> " ps
    where
    ps =
      (if r then ["read"] else []) <>
      (if w then ["write"] else []) <>
      (if x then ["execute"] else [])

instance semiringPerm :: Semiring Perm where
  add (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 || r1, w: w0 || w1, x: x0 || x1  }
  zero = none
  mul (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 && r1, w: w0 && w1, x: x0 && x1  }
  one = all

-- | Create a `Perm` value. The arguments represent the readable, writable, and
-- | executable permissions, in that order.
mkPerm :: Boolean -> Boolean -> Boolean -> Perm
mkPerm r w x = Perm { r: r, w: w, x: x }

-- | No permissions. This is the identity of the `Semigroup` operation `(<>)`
-- | for `Perm`.
none :: Perm
none = Perm { r: false, w: false, x: false }

-- | The "readable" permission.
read :: Perm
read = Perm { r: true, w: false, x: false }

-- | The "writable" permission.
write :: Perm
write = Perm { r: false, w: true, x: false }

-- | The "executable" permission.
execute :: Perm
execute = Perm { r: false, w: false, x: true }

-- | All permissions: readable, writable, and executable.
all :: Perm
all = read <> write <> execute

-- | A `Perms` value includes all the permissions information about a
-- | particular file or directory, by storing a `Perm` value for each of the
-- | file owner, the group, and any other users.
newtype Perms = Perms { u :: Perm, g :: Perm, o :: Perm }

instance eqPerms :: Eq Perms where
  (==) (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    u1 == u2  && g1 == g2 && o1 == o2
  (/=) x y = not (x == y)

instance ordPerms :: Ord Perms where
  compare (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    compare [u1, g1, o1] [u2, g2, o2]

instance showPerms :: Show Perms where
  show (Perms { u = u, g = g, o = o }) =
    "mkPerms " <> joinWith " " (f <$> [u, g, o])
    where
      f perm = let str = show perm
               in  if indexOf " " str == -1
                     then str
                     else "(" <> str <> ")"

-- | Attempt to parse a `Perms` value from a `String` containing an octal
-- | integer. For example,
-- | `permsFromString "0644" == Just (mkPerms (read <> write) read read)`.
permsFromString :: String -> Maybe Perms
permsFromString = _perms <<< toCharArray <<< dropPrefix zeroChar
  where
    zeroChar = fromCharCode 48

    dropPrefix x xs
      | charAt 0 xs == Just x = drop 1 xs
      | otherwise             = xs

    _perms [u, g, o] =
      mkPerms <$> permFromChar u
              <*> permFromChar g
              <*> permFromChar o
    _perms _ = Nothing

permFromChar :: Char -> Maybe Perm
permFromChar = _perm <<< charString
  where
    _perm "0" = Just $ none
    _perm "1" = Just $ execute
    _perm "2" = Just $ write
    _perm "3" = Just $ write <> execute
    _perm "4" = Just $ read
    _perm "5" = Just $ read <> execute
    _perm "6" = Just $ read <> write
    _perm "7" = Just $ read <> write <> execute
    _perm _   = Nothing

-- | Create a `Perms` value. The arguments represent the owner's, group's, and
-- | other users' permission sets, respectively.
mkPerms :: Perm -> Perm -> Perm -> Perms
mkPerms u g o = Perms { u: u, g: g, o: o }

-- | Convert a `Perm` to an octal digit. For example:
-- |
-- | * `permToInt r == 4`
-- | * `permToInt w == 2`
-- | * `permToInt (r <> w) == 6`
permToInt :: Perm -> Int
permToInt (Perm { r = r, w = w, x = x }) =
  fromNumber $
      (if r then 4 else 0)
    + (if w then 2 else 0)
    + (if x then 1 else 0)

-- | Convert a `Perm` to an octal string, via `permToInt`.
permToString :: Perm -> String
permToString = show <<< toNumber <<< permToInt

-- | Convert a `Perms` value to an octal string, in a format similar to that
-- | accepted by `chmod`. For example:
-- | `permsToString (mkPerms (read <> write) read read) == "0644"`
permsToString :: Perms -> String
permsToString (Perms { u = u, g = g, o = o }) =
     "0"
  ++ permToString u
  ++ permToString g
  ++ permToString o

-- | Convert a `Perms` value to an `Int`, via `permsToString`.
permsToInt :: Perms -> Int
permsToInt = fromNumber <<< readInt 8 <<< permsToString

module Node.FS.Perms
  ( Perm()
  , none
  , read
  , write
  , execute
  , all
  , Perms()
  , mkPerms
  , permsFromString
  , permsToString
  , permsToInt
  ) where

import Global (readInt)
import Data.Array () -- for Semigroup and Functor instances
import Data.Maybe (Maybe(..))
import Data.Char (Char(), charString, fromCharCode)
import Data.String (toCharArray, joinWith, drop, charAt, indexOf)
import Data.Int (Int(), fromNumber, toNumber)

-- | A `Perm` value specifies what is allowed to be done with a particular
-- | file by a particular class of user — that is, whether it is
-- | readable, writable, and/or executable. It has a semigroup instance, which
-- | allows you to combine permissions; for example, `read <> write` means
-- | "readable and writable".
newtype Perm = Perm { r :: Boolean, w :: Boolean, x :: Boolean }

instance eqPerm :: Eq Perm where
  (==) (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    r1 == r2  && w1 == w2 && x1 == x2
  (/=) x y = not (x == y)

instance ordPerm :: Ord Perm where
  compare (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    compare [r1, w1, x1] [r2, w2, x2]

instance showPerm :: Show Perm where
  show p | p == none = "none"
  show p | p == all  = "all"
  show (Perm { r = r, w = w, x = x }) =
    joinWith " <> " ps
    where
    ps =
      (if r then ["read"] else []) <>
      (if w then ["write"] else []) <>
      (if x then ["execute"] else [])

instance semigroupPerm :: Semigroup Perm where
  (<>) (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 || r1, w: w0 || w1, x: x0 || x1  }

instance semiringPerm :: Semiring Perm where
  (+) = (<>)
  zero = none
  (*) (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 && r1, w: w0 && w1, x: x0 && x1  }
  one = all

-- | Create a `Perm` value. The arguments represent the readable, writable, and
-- | executable permissions, in that order.
mkPerm :: Boolean -> Boolean -> Boolean -> Perm
mkPerm r w x = Perm { r: r, w: w, x: x }

-- | No permissions. This is the identity of the `Semigroup` operation `(<>)`
-- | for `Perm`.
none :: Perm
none = Perm { r: false, w: false, x: false }

-- | The "readable" permission.
read :: Perm
read = Perm { r: true, w: false, x: false }

-- | The "writable" permission.
write :: Perm
write = Perm { r: false, w: true, x: false }

-- | The "executable" permission.
execute :: Perm
execute = Perm { r: false, w: false, x: true }

-- | All permissions: readable, writable, and executable.
all :: Perm
all = read <> write <> execute

-- | A `Perms` value includes all the permissions information about a
-- | particular file or directory, by storing a `Perm` value for each of the
-- | file owner, the group, and any other users.
newtype Perms = Perms { u :: Perm, g :: Perm, o :: Perm }

instance eqPerms :: Eq Perms where
  (==) (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    u1 == u2  && g1 == g2 && o1 == o2
  (/=) x y = not (x == y)

instance ordPerms :: Ord Perms where
  compare (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    compare [u1, g1, o1] [u2, g2, o2]

instance showPerms :: Show Perms where
  show (Perms { u = u, g = g, o = o }) =
    "mkPerms " <> joinWith " " (f <$> [u, g, o])
    where
      f perm = let str = show perm
               in  if indexOf " " str == -1
                     then str
                     else "(" <> str <> ")"

-- | Attempt to parse a `Perms` value from a `String` containing an octal
-- | integer. For example,
-- | `permsFromString "0644" == Just (mkPerms (read <> write) read read)`.
permsFromString :: String -> Maybe Perms
permsFromString = _perms <<< toCharArray <<< dropPrefix zeroChar
  where
    zeroChar = fromCharCode 48

    dropPrefix x xs
      | charAt 0 xs == Just x = drop 1 xs
      | otherwise             = xs

    _perms [u, g, o] =
      mkPerms <$> permFromChar u
              <*> permFromChar g
              <*> permFromChar o
    _perms _ = Nothing

permFromChar :: Char -> Maybe Perm
permFromChar = _perm <<< charString
  where
    _perm "0" = Just $ none
    _perm "1" = Just $ execute
    _perm "2" = Just $ write
    _perm "3" = Just $ write <> execute
    _perm "4" = Just $ read
    _perm "5" = Just $ read <> execute
    _perm "6" = Just $ read <> write
    _perm "7" = Just $ read <> write <> execute
    _perm _   = Nothing

-- | Create a `Perms` value. The arguments represent the owner's, group's, and
-- | other users' permission sets, respectively.
mkPerms :: Perm -> Perm -> Perm -> Perms
mkPerms u g o = Perms { u: u, g: g, o: o }

-- | Convert a `Perm` to an octal digit. For example:
-- |
-- | * `permToInt r == 4`
-- | * `permToInt w == 2`
-- | * `permToInt (r <> w) == 6`
permToInt :: Perm -> Int
permToInt (Perm { r = r, w = w, x = x }) =
  fromNumber $
      (if r then 4 else 0)
    + (if w then 2 else 0)
    + (if x then 1 else 0)

-- | Convert a `Perm` to an octal string, via `permToInt`.
permToString :: Perm -> String
permToString = show <<< toNumber <<< permToInt

-- | Convert a `Perms` value to an octal string, in a format similar to that
-- | accepted by `chmod`. For example:
-- | `permsToString (mkPerms (read <> write) read read) == "0644"`
permsToString :: Perms -> String
permsToString (Perms { u = u, g = g, o = o }) =
     "0"
  ++ permToString u
  ++ permToString g
  ++ permToString o

-- | Convert a `Perms` value to an `Int`, via `permsToString`.
permsToInt :: Perms -> Int
permsToInt = fromNumber <<< readInt 8 <<< permsToString


More `Int` usage, special cases for negative bounds

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , span
  , drop
  , dropWhile
  , take
  , takeWhile
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , delete
  , deleteBy
  , (\\)
  , intersect
  , intersectBy
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , replicate
  ) where

import Control.Alt (Alt)
import Control.Plus (Plus)
import Control.Alternative (Alternative)
import Control.MonadPlus (MonadPlus)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Function (Fn4(), runFn4)
import Data.Int (Int(), toNumber)
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

-- | This operator provides a safe way to read a value at a particular index
-- | from an array.
(!!) :: forall a. [a] -> Int -> Maybe a
(!!) xs n | n < zero || n >= length xs = Nothing
          | otherwise = Just (xs `unsafeIndex` toNumber n)

-- | Append an element to the end of an array, creating a new array.
foreign import snoc
  """
  function snoc(l) {
    return function (e) {
      var l1 = l.slice();
      l1.push(e);
      return l1;
    };
  }
  """ :: forall a. [a] -> a -> [a]

-- | Create an array of one element
singleton :: forall a. a -> [a]
singleton a = [a]

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. [a] -> Maybe a
head xs = xs !! zero

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. [a] -> Maybe a
last xs = xs !! (length xs - one)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice zero (length xs - one) xs)

-- | Test whether an array is empty.
null :: forall a. [a] -> Boolean
null [] = true
null _  = false

-- | Get the number of elements in an array.
foreign import length
  """
  function length (xs) {
    return xs.length;
  }
  """ :: forall a. [a] -> Int

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> [a] -> Maybe Int
findIndex f xs = runFn4 findIndexJS Just Nothing f xs

foreign import findIndexJS
  """
  function findIndexJS(just, nothing, f, arr) {
    for (var i = 0, l = arr.length; i < l; i++) {
      if (f(arr[i])) return just(i);
    }
    return nothing;
  };
  """ :: forall a. Fn4 (Int -> Maybe Int) (Maybe Int) (a -> Boolean) [a] (Maybe Int)

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> [a] -> Maybe Int
findLastIndex f xs = runFn4 findLastIndexJS Just Nothing f xs

foreign import findLastIndexJS
  """
  function findLastIndexJS(just, nothing, f, arr) {
    for (var i = arr.length - 1; i >= 0; i--) {
      if (f(arr[i])) return just(i);
    }
    return nothing;
  }
  """ :: forall a. Fn4 (Int -> Maybe Int) (Maybe Int) (a -> Boolean) [a] (Maybe Int)

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> [a] -> Maybe Int
elemIndex x = findIndex ((==) x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> [a] -> Maybe Int
elemLastIndex x = findLastIndex ((==) x)

-- | Concatenate two arrays, creating a new array.
foreign import append
  """
  function append (l1) {
    return function (l2) {
      return l1.concat(l2);
    };
  }
  """ :: forall a. [a] -> [a] -> [a]

-- | Flatten an array of arrays, creating a new array.
foreign import concat
  """
  function concat (xss) {
    var result = [];
    for (var i = 0, l = xss.length; i < l; i++) {
      result.push.apply(result, xss[i]);
    }
    return result;
  }
  """ :: forall a. [[a]] -> [a]

-- | Reverse an array, creating a copy
foreign import reverse
  """
  function reverse (l) {
    return l.slice().reverse();
  }
  """ :: forall a. [a] -> [a]

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified predicate
-- | 2. the remaining elements
-- |
-- | For example,
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop
  """
  function drop (n) {
    return function (l) {
      return n < 1 ? l : l.slice(n);
    };
  }
  """ :: forall a. Int -> [a] -> [a]

-- | Remove the longest initial subarray for which all element satisfy the specified predicate,
-- | creating a new array.
dropWhile :: forall a. (a -> Boolean) -> [a] -> [a]
dropWhile p xs = (span p xs).rest

-- | Keep only a number of elements from the start of an array, creating a new array.
take :: forall a. Int -> [a] -> [a]
take n xs | n < one = []
          | otherwise = slice zero n xs

-- | Calculate the longest initial subarray for which all element satisfy the specified predicate,
-- | creating a new array.
takeWhile :: forall a. (a -> Boolean) -> [a] -> [a]
takeWhile p xs = (span p xs).init

-- | Create a copy of a subarray
foreign import slice
  """
  function slice (s) {
    return function (e) {
      return function (l) {
        return l.slice(s, e);
      };
    };
  }
  """ :: forall a. Int -> Int -> [a] -> [a]

-- | Insert an element at the specified index, creating a new array.
foreign import insertAt
  """
  function insertAt (index) {
    return function (a) {
      return function (l) {
        var l1 = l.slice();
        l1.splice(index, 0, a);
        return l1;
      };
    };
  }
  """ :: forall a. Int -> a -> [a] -> [a]

-- | Delete the element at the specified index, creating a new array.
foreign import deleteAt
  """
  function deleteAt (index) {
    return function (n) {
      return function (l) {
        var l1 = l.slice();
        l1.splice(index, n);
        return l1;
      };
    };
  }
  """ :: forall a. Int -> Int -> [a] -> [a]

-- | Change the element at the specified index, creating a new array.
foreign import updateAt
  """
  function updateAt (i) {
    return function (a) {
      return function (l) {
        if (i < 0 || i >= l.length) return l;
        var l1 = l.slice();
        l1[i] = a;
        return l1;
      };
    };
  }
  """ :: forall a. Int -> a -> [a] -> [a]

-- | Apply a function to the element at the specified index, creating a new array.
modifyAt :: forall a. Int -> (a -> a) -> [a] -> [a]
modifyAt i f xs = maybe xs (\x -> updateAt i (f x) xs) (xs !! i)

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

-- | Delete the first element of an array which matches the specified value, under the
-- | equivalence relation provided in the first argument, creating a new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = maybe ys (\i -> deleteAt i one ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the first array,
-- | creating a new array.
(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

-- | Calculate the intersection of two arrays, using the specified equivalence relation
-- | to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
foreign import concatMap
  """
  function concatMap (f) {
    return function (arr) {
      var result = [];
      for (var i = 0, l = arr.length; i < l; i++) {
        Array.prototype.push.apply(result, f(arr[i]));
      }
      return result;
    };
  }
  """ :: forall a b. (a -> [b]) -> [a] -> [b]

-- | Apply a function to each element in an array, creating a new array.
foreign import map
  """
  function map (f) {
    return function (arr) {
      var l = arr.length;
      var result = new Array(l);
      for (var i = 0; i < l; i++) {
        result[i] = f(arr[i]);
      }
      return result;
    };
  }
  """ :: forall a b. (a -> b) -> [a] -> [b]

-- | Apply a function to each element in an array, keeping only the results which
-- | contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter
  """
  function filter (f) {
    return function (arr) {
      var n = 0;
      var result = [];
      for (var i = 0, l = arr.length; i < l; i++) {
        if (f(arr[i])) result[n++] = arr[i];
      }
      return result;
    };
  }
  """ :: forall a. (a -> Boolean) -> [a] -> [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range
  """
  function range (start) {
    return function (end) {
      var i = start;
      var step = i > e ? -1 : 1;
      var result = [i], n = 1;
      while (i !== end) {
        i += step;
        result[n++] = i;
      }
      return result;
    };
  }
  """ :: Int -> Int -> [Int]

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Int -> Int -> [Int]
(..) = range

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith
  """
  function zipWith (f) {
    return function (xs) {
      return function (ys) {
        var l = xs.length < ys.length ? xs.length : ys.length;
        var result = new Array(l);
        for (var i = 0; i < l; i++) {
          result[i] = f(xs[i])(ys[i]);
        }
        return result;
      };
    };
  }
  """ :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

-- | Remove the duplicates from an array, where element equality is determined by the
-- | specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  """
  function sortJS (f) {
    return function (l) {
      return l.slice().sort(function (x, y) {
        return f(x)(y);
      });
    };
  }
  """ :: forall a. (a -> a -> Number) -> [a] -> [a]

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | For example,
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Sort and group the elements of an array into arrays.
-- |
-- | For example,
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the specified
-- | equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs
                     in go ((x:sp.init):acc) op sp.rest

-- | Create an array with repeated instances of a value.
foreign import replicate
  """
  function replicate(nn) {
    return function(v) {
      var n = nn > 0 ? nn : 0;
      var r = new Array(n);
      for (var i = 0; i < n; i++) r[i] = v;
      return r;
     };
  }
  """ :: forall a. Int -> a -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , span
  , drop
  , dropWhile
  , take
  , takeWhile
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , delete
  , deleteBy
  , (\\)
  , intersect
  , intersectBy
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , replicate
  ) where

import Control.Alt (Alt)
import Control.Plus (Plus)
import Control.Alternative (Alternative)
import Control.MonadPlus (MonadPlus)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Function (Fn4(), runFn4)
import Data.Int (Int(), toNumber)
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

-- | This operator provides a safe way to read a value at a particular index
-- | from an array.
(!!) :: forall a. [a] -> Int -> Maybe a
(!!) xs n | n < zero || n >= length xs = Nothing
          | otherwise = Just (xs `unsafeIndex` toNumber n)

-- | Append an element to the end of an array, creating a new array.
foreign import snoc
  """
  function snoc(l) {
    return function (e) {
      var l1 = l.slice();
      l1.push(e);
      return l1;
    };
  }
  """ :: forall a. [a] -> a -> [a]

-- | Create an array of one element
singleton :: forall a. a -> [a]
singleton a = [a]

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. [a] -> Maybe a
head xs = xs !! zero

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. [a] -> Maybe a
last xs = xs !! (length xs - one)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice zero (length xs - one) xs)

-- | Test whether an array is empty.
null :: forall a. [a] -> Boolean
null [] = true
null _  = false

-- | Get the number of elements in an array.
foreign import length
  """
  function length (xs) {
    return xs.length;
  }
  """ :: forall a. [a] -> Int

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> [a] -> Maybe Int
findIndex f xs = runFn4 findIndexJS Just Nothing f xs

foreign import findIndexJS
  """
  function findIndexJS(just, nothing, f, arr) {
    for (var i = 0, l = arr.length; i < l; i++) {
      if (f(arr[i])) return just(i);
    }
    return nothing;
  };
  """ :: forall a. Fn4 (Int -> Maybe Int) (Maybe Int) (a -> Boolean) [a] (Maybe Int)

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> [a] -> Maybe Int
findLastIndex f xs = runFn4 findLastIndexJS Just Nothing f xs

foreign import findLastIndexJS
  """
  function findLastIndexJS(just, nothing, f, arr) {
    for (var i = arr.length - 1; i >= 0; i--) {
      if (f(arr[i])) return just(i);
    }
    return nothing;
  }
  """ :: forall a. Fn4 (Int -> Maybe Int) (Maybe Int) (a -> Boolean) [a] (Maybe Int)

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> [a] -> Maybe Int
elemIndex x = findIndex ((==) x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> [a] -> Maybe Int
elemLastIndex x = findLastIndex ((==) x)

-- | Concatenate two arrays, creating a new array.
foreign import append
  """
  function append (l1) {
    return function (l2) {
      return l1.concat(l2);
    };
  }
  """ :: forall a. [a] -> [a] -> [a]

-- | Flatten an array of arrays, creating a new array.
foreign import concat
  """
  function concat (xss) {
    var result = [];
    for (var i = 0, l = xss.length; i < l; i++) {
      result.push.apply(result, xss[i]);
    }
    return result;
  }
  """ :: forall a. [[a]] -> [a]

-- | Reverse an array, creating a copy
foreign import reverse
  """
  function reverse (l) {
    return l.slice().reverse();
  }
  """ :: forall a. [a] -> [a]

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified predicate
-- | 2. the remaining elements
-- |
-- | For example,
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop
  """
  function drop (n) {
    return function (l) {
      return l.slice(n);
    };
  }
  """ :: forall a. Int -> [a] -> [a]

-- | Remove the longest initial subarray for which all element satisfy the specified predicate,
-- | creating a new array.
dropWhile :: forall a. (a -> Boolean) -> [a] -> [a]
dropWhile p xs = (span p xs).rest

-- | Keep only a number of elements from the start of an array, creating a new array.
take :: forall a. Int -> [a] -> [a]
take n = slice zero n

-- | Calculate the longest initial subarray for which all element satisfy the specified predicate,
-- | creating a new array.
takeWhile :: forall a. (a -> Boolean) -> [a] -> [a]
takeWhile p xs = (span p xs).init

-- | Create a copy of a subarray
foreign import slice
  """
  function slice (s) {
    return function (e) {
      return function (l) {
        return l.slice(s, e);
      };
    };
  }
  """ :: forall a. Int -> Int -> [a] -> [a]

-- | Insert an element at the specified index, creating a new array.
foreign import insertAt
  """
  function insertAt (index) {
    return function (a) {
      return function (l) {
        var l1 = l.slice();
        l1.splice(index, 0, a);
        return l1;
      };
    };
  }
  """ :: forall a. Int -> a -> [a] -> [a]

-- | Delete the element at the specified index, creating a new array.
foreign import deleteAt
  """
  function deleteAt (index) {
    return function (n) {
      return function (l) {
        var l1 = l.slice();
        l1.splice(index, n);
        return l1;
      };
    };
  }
  """ :: forall a. Int -> Int -> [a] -> [a]

-- | Change the element at the specified index, creating a new array.
foreign import updateAt
  """
  function updateAt (i) {
    return function (a) {
      return function (l) {
        if (i < 0 || i >= l.length) return l;
        var l1 = l.slice();
        l1[i] = a;
        return l1;
      };
    };
  }
  """ :: forall a. Int -> a -> [a] -> [a]

-- | Apply a function to the element at the specified index, creating a new array.
modifyAt :: forall a. Int -> (a -> a) -> [a] -> [a]
modifyAt i f xs = maybe xs (\x -> updateAt i (f x) xs) (xs !! i)

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

-- | Delete the first element of an array which matches the specified value, under the
-- | equivalence relation provided in the first argument, creating a new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = maybe ys (\i -> deleteAt i one ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the first array,
-- | creating a new array.
(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

-- | Calculate the intersection of two arrays, using the specified equivalence relation
-- | to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
foreign import concatMap
  """
  function concatMap (f) {
    return function (arr) {
      var result = [];
      for (var i = 0, l = arr.length; i < l; i++) {
        Array.prototype.push.apply(result, f(arr[i]));
      }
      return result;
    };
  }
  """ :: forall a b. (a -> [b]) -> [a] -> [b]

-- | Apply a function to each element in an array, creating a new array.
foreign import map
  """
  function map (f) {
    return function (arr) {
      var l = arr.length;
      var result = new Array(l);
      for (var i = 0; i < l; i++) {
        result[i] = f(arr[i]);
      }
      return result;
    };
  }
  """ :: forall a b. (a -> b) -> [a] -> [b]

-- | Apply a function to each element in an array, keeping only the results which
-- | contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter
  """
  function filter (f) {
    return function (arr) {
      var n = 0;
      var result = [];
      for (var i = 0, l = arr.length; i < l; i++) {
        if (f(arr[i])) result[n++] = arr[i];
      }
      return result;
    };
  }
  """ :: forall a. (a -> Boolean) -> [a] -> [a]

-- | Create an array containing a range of numbers, including both endpoints.
foreign import range
  """
  function range (start) {
    return function (end) {
      var i = ~~start, e = ~~end;
      var step = i > e ? -1 : 1;
      var result = [i], n = 1;
      while (i !== e) {
        i += step;
        result[n++] = i;
      }
      return result;
    };
  }
  """ :: Number -> Number -> [Number]

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Number -> Number -> [Number]
(..) = range

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith
  """
  function zipWith (f) {
    return function (xs) {
      return function (ys) {
        var l = xs.length < ys.length ? xs.length : ys.length;
        var result = new Array(l);
        for (var i = 0; i < l; i++) {
          result[i] = f(xs[i])(ys[i]);
        }
        return result;
      };
    };
  }
  """ :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

-- | Remove the duplicates from an array, where element equality is determined by the
-- | specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  """
  function sortJS (f) {
    return function (l) {
      return l.slice().sort(function (x, y) {
        return f(x)(y);
      });
    };
  }
  """ :: forall a. (a -> a -> Number) -> [a] -> [a]

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | For example,
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Sort and group the elements of an array into arrays.
-- |
-- | For example,
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the specified
-- | equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs
                     in go ((x:sp.init):acc) op sp.rest

-- | Create an array with repeated instances of a value.
foreign import replicate
  """
  function replicate(nn) {
    return function(v) {
      var n = nn > 0 ? nn : 0;
      var r = new Array(n);
      for (var i = 0; i < n; i++) r[i] = v;
      return r;
     };
  }
  """ :: forall a. Int -> a -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []


Implement basic zooming

Implement basic zooming

module Genetics.Browser.UI.Native where

import Prelude

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

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

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

genF :: String -> Bp -> Bp -> Aff _ (Feature Bp Number)
genF chr' min max = liftEff do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

fileFetch :: String
          -> View
          -- -> Aff _ Json
          -> Fetch _
fileFetch url view = do

  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
        -- TODO this might get fucked up due to exponential notation
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-5.0) * (Math.log score / Math.log 10.0))

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

glyphify :: View
         -> Feature Bp Number
         -> Glyph Unit
glyphify v (Feature chr min max score) = do
  let height = 30.0
      color  = "red"
      x = bpToPixels v.scale (min - v.min)
      -- x = unwrap min
      -- midX   = min + ((max - min) / 2.0)
  stroke color
  circle { x: x, y: height } 3.0
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

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

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

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

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

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

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

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

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

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

  -- toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
-- horDragEv :: Event (Maybe Point) -> Event Number
-- horDragEv ev = ptSum `sampleOn_` doneEv
--   where doneEv = filter isNothing ev
--         ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

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

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

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

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

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

        f (ModScale g) v' = v' { scale = g v'.scale }

        f (SetScale s) v' = v' { scale = s }

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

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

-- TODO: set a range to jump the view to
-- TODO: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

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

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

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      s :: BpPerPixel
      s = BpPerPixel $ 100000.0 / w
      v :: View
      v = { min: minView, max: maxView, scale: s }
      f :: View -> Fetch _
      f = fileFetch "http://localhost:8080/gwas.json"
      -- f = fetchWithView 100

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      scroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0) <|>
                    scroll <|>
                    btnZoom (wrap <<< (_ * 0.8) <<< unwrap) (wrap <<< (_ * 1.2) <<< unwrap)
                    -- (map ScrollPixels) cDrag
      viewB = viewBehavior updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    launchAff $ fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx

main :: Eff _ _
main = launchAff do
  x <- fileFetch "http://localhost:8080/gwas.json" (unsafeCoerce unit)
  liftEff $ log $ unsafeStringify x
  browser

module Genetics.Browser.UI.Native where

import Prelude

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

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

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

genF :: String -> Bp -> Bp -> Aff _ (Feature Bp Number)
genF chr' min max = liftEff do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

fileFetch :: String
          -> View
          -- -> Aff _ Json
          -> Fetch _
fileFetch url view = do

  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
        -- TODO this might get fucked up due to exponential notation
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-5.0) * (Math.log score / Math.log 10.0))

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

glyphify :: View
         -> Feature Bp Number
         -> Glyph Unit
glyphify v (Feature chr min max score) = do
  let height = 30.0
      color  = "red"
      x = bpToPixels v.scale (min - v.min)
      -- x = unwrap min
      -- midX   = min + ((max - min) / 2.0)
  stroke color
  circle { x: x, y: height } 3.0
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]
  -- path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

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

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

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

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

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

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

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

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

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

  -- toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
-- horDragEv :: Event (Maybe Point) -> Event Number
-- horDragEv ev = ptSum `sampleOn_` doneEv
--   where doneEv = filter isNothing ev
--         ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

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

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

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

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

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

        f (ModScale g) v' = v' { scale = g v'.scale }

        f (SetScale s) v' = v' { scale = s }

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

-- TODO: set a range to jump the view to
-- TODO: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

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

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

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      s :: BpPerPixel
      s = BpPerPixel $ 100000.0 / w
      v :: View
      v = { min: minView, max: maxView, scale: s }
      f :: View -> Fetch _
      f = fileFetch "http://localhost:8080/gwas.json"
      -- f = fetchWithView 100

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      scroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0) <|>
                    scroll
                    -- (map ScrollPixels) cDrag
      viewB = viewBehavior updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    launchAff $ fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx

main :: Eff _ _
main = launchAff do
  x <- fileFetch "http://localhost:8080/gwas.json" (unsafeCoerce unit)
  liftEff $ log $ unsafeStringify x
  browser


Export Table as Tab in new file

Export Table as Tab in new file

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  , Tab
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.List
import Data.Typelevel.Num

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab size cols cells = Table
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.List
import Data.Typelevel.Num

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Table size cols cells = Table
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }


[CSE-62] Add http endpoint of `search`

[CSE-62] Add http endpoint of `search`

module Explorer.Api.Http where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (EndpointError(..), Endpoint)
import Explorer.Types.State (CBlockEntries, CTxEntries, CTxBriefs)
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CBlockSummary, CHash(..), CHashSearchResult, CSearchId(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
-- endpointPrefix = "http://localhost:8100/api/"
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. (Generic a, Requestable r) => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks
fetchLatestBlocks :: forall eff. Aff (ajax::AJAX | eff) CBlockEntries
fetchLatestBlocks = get "blocks/last"

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) = get $ "blocks/txs/" <> hash

-- txs
fetchLatestTxs :: forall eff. Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs = get "txs/last"

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> address

-- search
search :: forall eff. CSearchId -> Aff (ajax::AJAX | eff) CHashSearchResult
search (CSearchId id) = get $ "search/" <> id

module Explorer.Api.Http where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (EndpointError(..), Endpoint)
import Explorer.Types.State (CBlockEntries, CTxEntries, CTxBriefs)
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CBlockSummary, CHash(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
-- endpointPrefix = "http://localhost:8100/api/"
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. (Generic a, Requestable r) => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks
fetchLatestBlocks :: forall eff. Aff (ajax::AJAX | eff) CBlockEntries
fetchLatestBlocks = get "blocks/last"

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) = get $ "blocks/txs/" <> hash

-- txs
fetchLatestTxs :: forall eff. Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs = get "txs/last"

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> address


Add lists

Add lists

module Web
  ( exprToJQuery
  , Handler ()
  ) where

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

import Data.Traversable (for, zipWithA)
import Data.Maybe
import Data.Array ((..), length)
import Control.Apply ((*>))

import AST
import Evaluator

type Handler = forall eff. Expr -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\je _ -> J.stopImmediatePropagation je *> evaluate p expr handler) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)
    List es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      list js >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

list :: forall eff. [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "List" ["list"]
  for js (flip J.append dls)
  return dls

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

evaluate :: forall eff. Path -> Expr -> Handler -> Eff (dom :: DOM | eff) Unit
evaluate p expr handler = case evalPath1 Data.StrMap.empty p expr of
  Nothing    -> return unit
  Just expr' -> handler expr'

module Web
  ( exprToJQuery
  , Handler ()
  ) where

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

import Data.Traversable (for)
import Data.Maybe

import AST
import Evaluator

type Handler = forall eff. Expr -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\je _ -> J.stopImmediatePropagation je *> evaluate p expr handler) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

evaluate :: forall eff. Path -> Expr -> Handler -> Eff (dom :: DOM | eff) Unit
evaluate p expr handler = case evalPath1 Data.StrMap.empty p expr of
  Nothing    -> return unit
  Just expr' -> handler expr'