Fixed "for" HTML attribute

Fixed "for" HTML attribute

-- | This module enumerates some common HTML attributes, and provides additional
-- | helper functions for working with CSS classes.

module Halogen.HTML.Attributes
  ( ClassName()
  , className
  , runClassName

  , AttributeName()
  , attributeName
  , runAttributeName

  , EventName()
  , eventName
  , runEventName

  , IsAttribute
  , toAttrString

  , ExistsR()
  , mkExistsR
  , runExistsR

  , AttrF(..)
  , HandlerF(..)

  , Attr(..)

  , attr
  , handler
  , initializer
  , finalizer

  , key

  , alt
  , charset
  , class_
  , classes
  , colSpan
  , rowSpan
  , content
  , for
  , height
  , href
  , httpEquiv
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , required
  , readonly
  , spellcheck
  , enabled
  , checked
  , selected
  , placeholder
  ) where

import DOM

import Data.Maybe
import Data.Tuple
import Data.Either (either)
import Data.Foreign
import Data.Monoid (mempty)
import Data.Array (map)
import Data.String (joinWith)
import Data.Traversable (mapAccumL)
import Data.Exists

import Control.Monad.Eff
import Control.Monad.ST

import Halogen.Internal.VirtualDOM
import Halogen.HTML.Events.Types
import Halogen.HTML.Events.Handler

-- | We need a variant of `Exists` which works for type constructors which accept a _row_ of types.
data ExistsR (f :: # * -> *)

foreign import unsafeCoerce
  "function unsafeCoerce(x) {\
  \  return x;\
  \}" :: forall a b. a -> b

runExistsR :: forall f r. (forall a. f a -> r) -> ExistsR f -> r
runExistsR = unsafeCoerce

mkExistsR :: forall f a. f a -> ExistsR f
mkExistsR = unsafeCoerce

-- | The data which represents a typed attribute, hidden inside an existential package in
-- | the `Attr` type.
data AttrF value = AttrF (AttributeName value -> value -> String) (AttributeName value) value

-- | The data which represents a typed event handler, hidden inside an existential package in
-- | the `Attr` type.
data HandlerF i fields = HandlerF (EventName fields) (Event fields -> EventHandler i)

-- | A single attribute is either
-- |
-- | - An attribute
-- | - An event handler
data Attr i
  = Attr (Exists AttrF)
  | Handler (ExistsR (HandlerF i))
  | Initializer i
  | Finalizer i

instance functorAttr :: Functor Attr where
  (<$>) _ (Attr e) = Attr e
  (<$>) f (Handler e) = runExistsR (\(HandlerF name k) -> Handler (mkExistsR (HandlerF name (\e -> f <$> k e)))) e
  (<$>) f (Initializer i) = Initializer (f i)
  (<$>) f (Finalizer i) = Finalizer (f i)

-- | Create an attribute
attr :: forall value i. (IsAttribute value) => AttributeName value -> value -> Attr i
attr name v = Attr (mkExists (AttrF toAttrString name v))

-- | Create an event handler
handler :: forall fields i. EventName fields -> (Event fields -> EventHandler i) -> Attr i
handler name k = Handler (mkExistsR (HandlerF name k))

-- | Attach an initializer.
initializer :: forall i. i -> Attr i
initializer = Initializer

-- | Attach a finalizer.
finalizer :: forall i. i -> Attr i
finalizer = Finalizer

-- | A wrapper for strings which are used as CSS classes
newtype ClassName = ClassName String

-- Create a class name
className :: String -> ClassName
className = ClassName

-- | Unpack a class name
runClassName :: ClassName -> String
runClassName (ClassName s) = s

-- | A type-safe wrapper for attribute names
-- |
-- | The phantom type `value` describes the type of value which this attribute requires.
newtype AttributeName value = AttributeName String

-- | Create an attribute name
attributeName :: forall value. String -> AttributeName value
attributeName = AttributeName

-- | Unpack an attribute name
runAttributeName :: forall value. AttributeName value -> String
runAttributeName (AttributeName s) = s

-- | A type-safe wrapper for event names.
-- |
-- | The phantom type `fields` describes the event type which we can expect to exist on events
-- | corresponding to this name.
newtype EventName (fields :: # *) = EventName String

-- Create an event name
eventName :: forall fields. String -> EventName fields
eventName = EventName

-- | Unpack an event name
runEventName :: forall fields. EventName fields -> String
runEventName (EventName s) = s

-- | This type class captures those types which can be used as attribute values.
-- |
-- | `toAttrString` is an alternative to `show`, and is needed by `attr` in the string renderer.
class IsAttribute a where
  toAttrString :: AttributeName a -> a -> String

instance stringIsAttribute :: IsAttribute String where
  toAttrString _ s = s

instance numberIsAttribute :: IsAttribute Number where
  toAttrString _ n = show n

instance booleanIsAttribute :: IsAttribute Boolean where
  toAttrString name true = runAttributeName name
  toAttrString _ false = ""

-- Smart constructors

-- | The `key` property associates a unique key with a node, which can be used to
-- | implement a more efficient diff/patch.
key :: forall i. String -> Attr i
key = attr $ attributeName "key"

alt :: forall i. String -> Attr i
alt = attr $ attributeName "alt"

charset :: forall i. String -> Attr i
charset = attr $ attributeName "charset"

class_ :: forall i. ClassName -> Attr i
class_ = attr (attributeName "className") <<< runClassName

classes :: forall i. [ClassName] -> Attr i
classes ss = attr (attributeName "className") (joinWith " " $ map runClassName ss)

colSpan :: forall i. Number -> Attr i
colSpan = attr (attributeName "colSpan") <<< show

rowSpan :: forall i. Number -> Attr i
rowSpan = attr (attributeName "rowSpan") <<< show

content :: forall i. String -> Attr i
content = attr $ attributeName "content"

for :: forall i. String -> Attr i
for = attr $ attributeName "htmlFor"

height :: forall i. Number -> Attr i
height = attr (attributeName "height") <<< show

href :: forall i. String -> Attr i
href = attr $ attributeName "href"

httpEquiv :: forall i. String -> Attr i
httpEquiv = attr $ attributeName "http-equiv"

id_ :: forall i. String -> Attr i
id_ = attr $ attributeName "id"

name :: forall i. String -> Attr i
name = attr $ attributeName "name"

rel :: forall i. String -> Attr i
rel = attr $ attributeName "rel"

src :: forall i. String -> Attr i
src = attr $ attributeName "src"

target :: forall i. String -> Attr i
target = attr $ attributeName "target"

title :: forall i. String -> Attr i
title = attr $ attributeName "title"

type_ :: forall i. String -> Attr i
type_ = attr $ attributeName "type"

value :: forall i. String -> Attr i
value = attr $ attributeName "value"

width :: forall i. Number -> Attr i
width = attr (attributeName "width") <<< show

disabled :: forall i. Boolean -> Attr i
disabled = attr $ attributeName "disabled"

required :: forall i. Boolean -> Attr i
required = attr $ attributeName "required"

readonly :: forall i. Boolean -> Attr i
readonly = attr $ attributeName "readonly"

spellcheck :: forall i. Boolean -> Attr i
spellcheck = attr $ attributeName "spellcheck"

enabled :: forall i. Boolean -> Attr i
enabled = disabled <<< not

checked :: forall i. Boolean -> Attr i
checked = attr $ attributeName "checked"

selected :: forall i. Boolean -> Attr i
selected = attr $ attributeName "selected"

placeholder :: forall i. String -> Attr i
placeholder = attr $ attributeName "placeholder"

-- | This module enumerates some common HTML attributes, and provides additional
-- | helper functions for working with CSS classes.

module Halogen.HTML.Attributes
  ( ClassName()
  , className
  , runClassName

  , AttributeName()
  , attributeName
  , runAttributeName

  , EventName()
  , eventName
  , runEventName

  , IsAttribute
  , toAttrString

  , ExistsR()
  , mkExistsR
  , runExistsR

  , AttrF(..)
  , HandlerF(..)

  , Attr(..)

  , attr
  , handler
  , initializer
  , finalizer

  , key

  , alt
  , charset
  , class_
  , classes
  , colSpan
  , rowSpan
  , content
  , for
  , height
  , href
  , httpEquiv
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , required
  , readonly
  , spellcheck
  , enabled
  , checked
  , selected
  , placeholder
  ) where

import DOM

import Data.Maybe
import Data.Tuple
import Data.Either (either)
import Data.Foreign
import Data.Monoid (mempty)
import Data.Array (map)
import Data.String (joinWith)
import Data.Traversable (mapAccumL)
import Data.Exists

import Control.Monad.Eff
import Control.Monad.ST

import Halogen.Internal.VirtualDOM
import Halogen.HTML.Events.Types
import Halogen.HTML.Events.Handler

-- | We need a variant of `Exists` which works for type constructors which accept a _row_ of types.
data ExistsR (f :: # * -> *)

foreign import unsafeCoerce
  "function unsafeCoerce(x) {\
  \  return x;\
  \}" :: forall a b. a -> b

runExistsR :: forall f r. (forall a. f a -> r) -> ExistsR f -> r
runExistsR = unsafeCoerce

mkExistsR :: forall f a. f a -> ExistsR f
mkExistsR = unsafeCoerce

-- | The data which represents a typed attribute, hidden inside an existential package in
-- | the `Attr` type.
data AttrF value = AttrF (AttributeName value -> value -> String) (AttributeName value) value

-- | The data which represents a typed event handler, hidden inside an existential package in
-- | the `Attr` type.
data HandlerF i fields = HandlerF (EventName fields) (Event fields -> EventHandler i)

-- | A single attribute is either
-- |
-- | - An attribute
-- | - An event handler
data Attr i
  = Attr (Exists AttrF)
  | Handler (ExistsR (HandlerF i))
  | Initializer i
  | Finalizer i

instance functorAttr :: Functor Attr where
  (<$>) _ (Attr e) = Attr e
  (<$>) f (Handler e) = runExistsR (\(HandlerF name k) -> Handler (mkExistsR (HandlerF name (\e -> f <$> k e)))) e
  (<$>) f (Initializer i) = Initializer (f i)
  (<$>) f (Finalizer i) = Finalizer (f i)

-- | Create an attribute
attr :: forall value i. (IsAttribute value) => AttributeName value -> value -> Attr i
attr name v = Attr (mkExists (AttrF toAttrString name v))

-- | Create an event handler
handler :: forall fields i. EventName fields -> (Event fields -> EventHandler i) -> Attr i
handler name k = Handler (mkExistsR (HandlerF name k))

-- | Attach an initializer.
initializer :: forall i. i -> Attr i
initializer = Initializer

-- | Attach a finalizer.
finalizer :: forall i. i -> Attr i
finalizer = Finalizer

-- | A wrapper for strings which are used as CSS classes
newtype ClassName = ClassName String

-- Create a class name
className :: String -> ClassName
className = ClassName

-- | Unpack a class name
runClassName :: ClassName -> String
runClassName (ClassName s) = s

-- | A type-safe wrapper for attribute names
-- |
-- | The phantom type `value` describes the type of value which this attribute requires.
newtype AttributeName value = AttributeName String

-- | Create an attribute name
attributeName :: forall value. String -> AttributeName value
attributeName = AttributeName

-- | Unpack an attribute name
runAttributeName :: forall value. AttributeName value -> String
runAttributeName (AttributeName s) = s

-- | A type-safe wrapper for event names.
-- |
-- | The phantom type `fields` describes the event type which we can expect to exist on events
-- | corresponding to this name.
newtype EventName (fields :: # *) = EventName String

-- Create an event name
eventName :: forall fields. String -> EventName fields
eventName = EventName

-- | Unpack an event name
runEventName :: forall fields. EventName fields -> String
runEventName (EventName s) = s

-- | This type class captures those types which can be used as attribute values.
-- |
-- | `toAttrString` is an alternative to `show`, and is needed by `attr` in the string renderer.
class IsAttribute a where
  toAttrString :: AttributeName a -> a -> String

instance stringIsAttribute :: IsAttribute String where
  toAttrString _ s = s

instance numberIsAttribute :: IsAttribute Number where
  toAttrString _ n = show n

instance booleanIsAttribute :: IsAttribute Boolean where
  toAttrString name true = runAttributeName name
  toAttrString _ false = ""

-- Smart constructors

-- | The `key` property associates a unique key with a node, which can be used to
-- | implement a more efficient diff/patch.
key :: forall i. String -> Attr i
key = attr $ attributeName "key"

alt :: forall i. String -> Attr i
alt = attr $ attributeName "alt"

charset :: forall i. String -> Attr i
charset = attr $ attributeName "charset"

class_ :: forall i. ClassName -> Attr i
class_ = attr (attributeName "className") <<< runClassName

classes :: forall i. [ClassName] -> Attr i
classes ss = attr (attributeName "className") (joinWith " " $ map runClassName ss)

colSpan :: forall i. Number -> Attr i
colSpan = attr (attributeName "colSpan") <<< show

rowSpan :: forall i. Number -> Attr i
rowSpan = attr (attributeName "rowSpan") <<< show

content :: forall i. String -> Attr i
content = attr $ attributeName "content"

for :: forall i. String -> Attr i
for = attr $ attributeName "for"

height :: forall i. Number -> Attr i
height = attr (attributeName "height") <<< show

href :: forall i. String -> Attr i
href = attr $ attributeName "href"

httpEquiv :: forall i. String -> Attr i
httpEquiv = attr $ attributeName "http-equiv"

id_ :: forall i. String -> Attr i
id_ = attr $ attributeName "id"

name :: forall i. String -> Attr i
name = attr $ attributeName "name"

rel :: forall i. String -> Attr i
rel = attr $ attributeName "rel"

src :: forall i. String -> Attr i
src = attr $ attributeName "src"

target :: forall i. String -> Attr i
target = attr $ attributeName "target"

title :: forall i. String -> Attr i
title = attr $ attributeName "title"

type_ :: forall i. String -> Attr i
type_ = attr $ attributeName "type"

value :: forall i. String -> Attr i
value = attr $ attributeName "value"

width :: forall i. Number -> Attr i
width = attr (attributeName "width") <<< show

disabled :: forall i. Boolean -> Attr i
disabled = attr $ attributeName "disabled"

required :: forall i. Boolean -> Attr i
required = attr $ attributeName "required"

readonly :: forall i. Boolean -> Attr i
readonly = attr $ attributeName "readonly"

spellcheck :: forall i. Boolean -> Attr i
spellcheck = attr $ attributeName "spellcheck"

enabled :: forall i. Boolean -> Attr i
enabled = disabled <<< not

checked :: forall i. Boolean -> Attr i
checked = attr $ attributeName "checked"

selected :: forall i. Boolean -> Attr i
selected = attr $ attributeName "selected"

placeholder :: forall i. String -> Attr i
placeholder = attr $ attributeName "placeholder"


Prevent negative offsets in page numbers

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Notebook.Port (VarMapValue(), _VarMap)
import Model.Resource (Resource(), mkFile)
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import Data.Path.Pathy ((</>), parseAbsFile, rootDir, sandbox)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Data.StrMap as SM
import qualified Model.Notebook.Cell.JTableContent as JTC

import qualified Data.StrMap as SM

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ do
    numItems <- count file
    let numPages = Math.ceil (numItems / I.toNumber perPage)
        pageIndex' = I.fromNumber $ Math.max 0 $ Math.min (I.toNumber pageIndex) (numPages - 1)
    json <- sample file (pageIndex' * perPage) perPage
    return { numItems: numItems, pageNumber: pageIndex' + one, json: json }
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That results.pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

-- TODO: Remove String from being our error type.
queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql varMap)
  either errorInQuery (\out -> runJTable (mkFile (Left $ rootDir </> out)) cell) do
    j <- lmap message jobj
    out' <- j .? "out"
    path <- maybe (Left "Invalid file from SlamEngine") Right $ parseAbsFile out'
    maybe (Left "Could not sandbox SlamEngine file") Right $ sandbox rootDir path
  where
  varMap :: SM.StrMap VarMapValue
  varMap = fromMaybe SM.empty $ cell ^? _input.._VarMap

  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> err])
      `andThen` \_ -> finish cell

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Notebook.Port (VarMapValue(), _VarMap)
import Model.Resource (Resource(), mkFile)
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import Data.Path.Pathy ((</>), parseAbsFile, rootDir, sandbox)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Data.StrMap as SM
import qualified Model.Notebook.Cell.JTableContent as JTC

import qualified Data.StrMap as SM

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ do
    numItems <- count file
    let numPages = Math.ceil (numItems / I.toNumber perPage)
        pageIndex' = I.fromNumber $ Math.min (I.toNumber pageIndex) (numPages - 1)
    json <- sample file (pageIndex' * perPage) perPage
    return { numItems: numItems, pageNumber: pageIndex' + one, json: json }
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That results.pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

-- TODO: Remove String from being our error type.
queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql varMap)
  either errorInQuery (\out -> runJTable (mkFile (Left $ rootDir </> out)) cell) do
    j <- lmap message jobj
    out' <- j .? "out"
    path <- maybe (Left "Invalid file from SlamEngine") Right $ parseAbsFile out'
    maybe (Left "Could not sandbox SlamEngine file") Right $ sandbox rootDir path
  where
  varMap :: SM.StrMap VarMapValue
  varMap = fromMaybe SM.empty $ cell ^? _input.._VarMap

  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> err])
      `andThen` \_ -> finish cell


in progress

in progress


a game

a game

module Main where

import Prelude
import Control.Monad (when, unless)
import Math (ceil, max)
import Data.Int (toNumber)
import Data.Traversable (traverse)
import Data.List (List(..), (!!), (:))
import Data.List (zipWith,(!!)) as List
import Data.Array ((!!)) as Array
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Tuple (Tuple(..), fst, snd)
import Data.String (length) as Str
import Graphics.Canvas as C
import Graphics.Drawing as Draw
import Signal (runSignal, foldp) as S
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Timer (TIMER)
import DOM (DOM)

import Input as Input
import Utils
import Zipper
import CanvasUtils
import Shape
import Model

----------
-- Glue
----------

main :: forall e. Eff (console :: CONSOLE, dom :: DOM, timer :: TIMER, canvas :: C.Canvas | e) Unit
main = do
  Just canvas <- C.getCanvasElementById "canvas"
  context <- C.getContext2D canvas
  inn <- Input.input
  let game = S.foldp update initState inn
  S.runSignal (render context <$> game)

-----------
-- Model
-----------

type State =
  { qas :: Zipper QA
  , score :: Number
  , answer :: Answer
  , wall :: Number
  , done :: Boolean
  }

initState :: State
initState =
  { qas: Zipper
           (qa "1 + 1 =" (Tuple true "2" : Tuple false "1" : Tuple false "3" : Nil))
           Nil
           (qa "1 + 1 =" (Tuple false "1" : Tuple true "2" : Tuple false "3" : Nil) : Nil)
  , score: 300.0
  , answer: 0
  , wall: -300.0
  , done: false
  }

tick :: Number
tick = speed / 60.0

speed :: Number
speed = height / 5.0

wallHeight :: Number
wallHeight = 250.0

initPlayer :: Number
initPlayer = 300.0

initWall :: Number
initWall = -300.0

------------
-- Update
------------

update :: Input.Input -> State -> State
update input state =
  let new = state.wall > height + 300.0
      wall = if new then initWall else state.wall + tick
      match = maybe true (not <<< fst) $ (List.!! state.answer) $ (current state.qas).answers

      pos = height - state.score

      score =
        if    pos > wall
           && pos < wall + wallHeight
           && match
        then
          height - (wall + wallHeight)
        else
          state.score

      answer =
        if input.arrows.left == Input.Click then
          0
        else if input.arrows.up == Input.Click then
          1
        else if input.arrows.down == Input.Click then
          2
        else if input.arrows.right == Input.Click then
          3
        else
          state.answer

      doneAndQas = if new && score > 0.0 then next state.qas else Tuple (not state.done) state.qas
      done = not $ fst doneAndQas
      qas = snd doneAndQas
  in
      { qas: qas
      , wall: wall
      , score: if done then state.score else score
      , answer: answer
      , done: done
      }

------------
-- Render
------------

render :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
render context state = do
  clearCanvas context
  renderPlayer context state
  renderWall context state
  unless state.done (renderQAs context state)
  renderText context state
  when (state.score < -50.0) (renderGameOver context state)
  when state.done (renderGameComplete context state)
  pure unit

clearCanvas ctx = do
  C.setFillStyle "#1B1C1B" ctx
  C.fillRect ctx { x: 0.0, y: 0.0, w: width + 100.0, h: height + 100.0 }

renderPlayer :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderPlayer context state =
  let pos = height - state.score
      shape =
        fromMaybe (circle {x: 500.0, y: pos} 30.0) $
          (Array.!! state.answer)
            [ circle {x: 500.0, y: pos} 30.0
            , triangle {x:500.0, y: pos} 60.0
            , square {x: 500.0, y: pos} 50.0
            , ex {x: 500.0, y: pos} 50.0
            ]
  in
      Draw.render context shape

renderWall :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderWall context state =
  Draw.render context $
    daiKabe state.wall width wallHeight

renderText :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderText context state =
  Draw.render context $
    texts 26 pink { x: 20.0, y: 30.0 }
      (  show (position state.qas + if state.done then 1 else 0) <> " / " <> show (length state.qas)
      <> (" Score: " <> show (max 0.0 $ ceil state.score))
      )

renderGameOver :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderGameOver context state =
  Draw.render context $
    texts 46 red { x: width / 2.0 - 100.0, y: height / 2.0 } "Game Over"

renderGameComplete :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderGameComplete context state =
  Draw.render context $
    texts 46 green { x: width / 2.0 - 100.0, y: height / 2.0 - 100.0 } "Well Done!" <>
    texts 46 white { x: width / 2.0 - 180.0, y: height / 2.0 } ("Your Score is: " <> show (ceil state.score))

renderQAs :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderQAs context state = do
  Draw.render context $
    texts 36 white { x: width / 2.0 - toNumber (Str.length (current state.qas).question * 13), y: state.wall + 40.0 } (current state.qas).question
  void $ (traverse (Draw.render context) $
    List.zipWith (<>)
        ( circle   {x: 200.0, y: state.wall + 80.0} 30.0
        : triangle {x: 200.0, y: state.wall + 170.0} 60.0
        : square   {x: 650.0, y: state.wall + 80.0} 50.0
        : ex       {x: 650.0, y: state.wall + 170.0} 50.0
        : Nil
        ) $

        List.zipWith (\(Tuple x y) str -> texts 30 white { x: x, y: state.wall + y } str)
        ( Tuple 300.0 120.0
        : Tuple 300.0 210.0
        : Tuple 750.0 110.0
        : Tuple 750.0 210.0
        : Nil
        )
        (map snd (current state.qas).answers)
    )

module Main where

import Prelude
import Control.Monad (when)
import Math (ceil, max)
import Data.Traversable (traverse)
import Data.List (List(..), (!!), (:))
import Data.List ((!!)) as List
import Data.Array ((!!)) as Array
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Tuple (Tuple(..), fst, snd)
import Graphics.Canvas as C
import Graphics.Drawing as Draw
import Signal (runSignal, foldp) as S
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Timer (TIMER)
import DOM (DOM)

import Input as Input
import Utils
import Zipper
import CanvasUtils
import Shape
import Model

----------
-- Glue
----------

main :: forall e. Eff (console :: CONSOLE, dom :: DOM, timer :: TIMER, canvas :: C.Canvas | e) Unit
main = do
  Just canvas <- C.getCanvasElementById "canvas"
  context <- C.getContext2D canvas
  inn <- Input.input
  let game = S.foldp update initState inn
  S.runSignal (render context <$> game)

-----------
-- Model
-----------

type State =
  { qas :: Zipper QA
  , score :: Number
  , answer :: Answer
  , wall :: Number
  , done :: Boolean
  }

initState :: State
initState =
  { qas: Zipper
           (qa "1+1=" (Tuple true "2" : Tuple false "1" : Tuple false "3" : Nil))
           Nil
           (qa "1+1=" (Tuple false "1" : Tuple true "2" : Tuple false "3" : Nil) : Nil)
  , score: 300.0
  , answer: 0
  , wall: -300.0
  , done: false
  }

tick :: Number
tick = speed / 60.0

speed :: Number
speed = height / 5.0

wallHeight :: Number
wallHeight = 200.0

initPlayer :: Number
initPlayer = 300.0

initWall :: Number
initWall = -300.0

------------
-- Update
------------

update :: Input.Input -> State -> State
update input state =
  let new = state.wall > height + 300.0
      wall = if new then initWall else state.wall + tick
      match = maybe true (not <<< fst) $ (List.!! state.answer) $ (current state.qas).answers

      pos = height - state.score

      score =
        if    pos > wall
           && pos < wall + wallHeight
           && match
        then
          height - (wall + wallHeight)
        else
          state.score

      answer =
        if input.arrows.left == Input.Click then
          0
        else if input.arrows.up == Input.Click then
          1
        else if input.arrows.down == Input.Click then
          2
        else if input.arrows.right == Input.Click then
          3
        else
          state.answer

      doneAndQas = if new && score > 0.0 then next state.qas else Tuple (not state.done) state.qas
      done = not $ fst doneAndQas
      qas = snd doneAndQas
  in
      { qas: qas
      , wall: wall
      , score: if done then state.score else score
      , answer: answer
      , done: done
      }

------------
-- Render
------------

render :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
render context state = do
  clearCanvas context
  renderPlayer context state
  renderWall context state
  renderText context state
  when (state.score < -50.0) (renderGameOver context state)
  when state.done (renderGameComplete context state)
  pure unit

renderPlayer :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderPlayer context state =
  let pos = height - state.score
      shape =
        fromMaybe (circle {x: 500.0, y: pos} 30.0) $
          (Array.!! state.answer)
            [ circle {x: 500.0, y: pos} 30.0
            , triangle {x:500.0, y: pos} 60.0
            , square {x: 500.0, y: pos} 50.0
            , ex {x: 500.0, y: pos} 50.0
            ]
  in
      Draw.render context shape

renderWall :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderWall context state =
  Draw.render context $
    daiKabe state.wall width wallHeight

renderText :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderText context state =
  Draw.render context $
    texts 26 pink { x: 20.0, y: 30.0 }
      (  show (position state.qas + if state.done then 1 else 0) <> " / " <> show (length state.qas)
      <> (" Score: " <> show (max 0.0 $ ceil state.score))
      )

renderGameOver :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderGameOver context state =
  Draw.render context $
    texts 46 red { x: width / 2.0 - 100.0, y: height / 2.0 } "Game Over"

renderGameComplete :: C.Context2D -> State -> Eff ( canvas :: C.Canvas | _) Unit
renderGameComplete context state =
  Draw.render context $
    texts 46 green { x: width / 2.0 - 100.0, y: height / 2.0 - 100.0 } "Well Done!" <>
    texts 46 white { x: width / 2.0 - 180.0, y: height / 2.0 } ("Your Score is: " <> show (ceil state.score))

clearCanvas ctx = do
  C.setFillStyle "#1B1C1B" ctx
  C.fillRect ctx { x: 0.0, y: 0.0, w: width + 100.0, h: height + 100.0 }