show name

show name

module Graphics.Game where

import Prelude
import Color
import Data.Int
import Data.Array
import Data.Monoid
import Data.Foldable
import Chat.ServerTypes
import Data.Wizard.View as View
import Control.Category ((<<<))
import Control.Monad.Eff (Eff)
import Data.Function ((<<<))
import Data.Maybe (Maybe(..))
import Data.Wizard.View (GameView(..))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, CANVAS)
import Graphics.Drawing (Drawing, Shape, black, fillColor, filled, rectangle, render, text)
import Graphics.Drawing.Font

renderGame :: forall eff. Number -> Number -> String -> GameView -> Eff (canvas :: CANVAS | eff) Unit
renderGame cw ch id g =  do
  mCanvas <- getCanvasElementById id
  case mCanvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      clearRect ctx {x: 0.0, y: 0.0, w: cw, h: ch}
      render ctx $ drawState cw g
    Nothing -> pure unit

drawState :: Number -> GameView -> Drawing
drawState cw (GameView {terrain, players}) =  drawTerrain terrain <> (fold $ drawPlayer <$> players)

drawTerrain :: Array (View.Terrain) -> Drawing
drawTerrain = filled (fillColor black) <<< fold <<< (<$>) (\(View.Terrain pos shape) ->  drawShape pos shape)

drawPlayer :: View.PlayerView -> Drawing
drawPlayer (View.PlayerView (p@(View.Position x y)) s (View.Colour r g b) n) = (text (font serif 12 mempty) x y (fillColor black) n) <> (filled (fillColor (rgb r g b)) $ drawShape p s)

drawShape :: View.Position -> View.Shape -> Shape
drawShape (View.Position x y) (View.Rectangle w h) = rectangle x y w h

module Graphics.Game where

import Prelude
import Color
import Data.Int
import Data.Array
import Data.Monoid
import Data.Foldable
import Chat.ServerTypes
import Data.Wizard.View as View
import Control.Category ((<<<))
import Control.Monad.Eff (Eff)
import Data.Function ((<<<))
import Data.Maybe (Maybe(..))
import Data.Wizard.View (GameView(..))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, CANVAS)
import Graphics.Drawing (Drawing, Shape, black, fillColor, filled, rectangle, render)

renderGame :: forall eff. Number -> Number -> String -> GameView -> Eff (canvas :: CANVAS | eff) Unit
renderGame cw ch id g =  do
  mCanvas <- getCanvasElementById id
  case mCanvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      clearRect ctx {x: 0.0, y: 0.0, w: cw, h: ch}
      render ctx $ drawState cw g
    Nothing -> pure unit

drawState :: Number -> GameView -> Drawing
drawState cw (GameView {terrain, players}) =  drawTerrain terrain <> (fold $ drawPlayer <$> players)

drawTerrain :: Array (View.Terrain) -> Drawing
drawTerrain = filled (fillColor black) <<< fold <<< (<$>) (\(View.Terrain pos shape) ->  drawShape pos shape)

drawPlayer :: View.PlayerView -> Drawing
drawPlayer (View.PlayerView p s (View.Colour r g b) n) = filled (fillColor (rgb r g b)) $ drawShape p s

drawShape :: View.Position -> View.Shape -> Shape
drawShape (View.Position x y) (View.Rectangle w h) = rectangle x y w h


remove a purposeful failure

remove a purposeful failure

module Test.Main where

import Prelude

import Control.Monad.Aff
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (CONSOLE(), log, print)
import qualified Control.Monad.Aff.Console as A
import Control.Monad.Eff.Exception
import Data.Either
import Data.Maybe
import Data.Foreign
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Response
import Network.HTTP.Affjax.Request
import Network.HTTP.Method
import Network.HTTP.MimeType.Common
import Network.HTTP.RequestHeader
import Network.HTTP.StatusCode

foreign import logAny
  :: forall e a. a -> Eff (console :: CONSOLE | e) Unit

logAny' :: forall e a. a -> Assert e Unit
logAny' = liftEff <<< logAny

type Assert e a = Aff (err :: EXCEPTION, console :: CONSOLE, ajax :: AJAX | e) a

assertFail :: forall e a. String -> Assert e a
assertFail msg = let e = error msg
                 in makeAff \errback _ -> errback e

assertMsg :: forall e. String -> Boolean -> Assert e Unit
assertMsg _   true  = return unit
assertMsg msg false = assertFail msg

assertRight :: forall e a b. Either a b -> Assert e b
assertRight x = case x of
  Left y -> logAny' y >>= \_ -> assertFail "Expected a Right value"
  Right y -> return y

assertLeft :: forall e a b. Either a b -> Assert e a
assertLeft x = case x of
  Right y -> logAny' y >>= \_ -> assertFail "Expected a Left value"
  Left y -> return y

assertEq :: forall e a. (Eq a, Show a) => a -> a -> Assert e Unit
assertEq x y = if x == y
                 then return unit
                 else assertFail $ "Expected " <> show x <> ", got " <> show y

-- | For helping type inference
typeIs :: forall e a. a -> Assert e Unit
typeIs = const (return unit)

main = runAff throwException (const $ log "affjax: All good!") $ do
  let ok200 = StatusCode 200
  let notFound404 = StatusCode 404

  A.log "GET /mirror: should be 200 OK"
  (attempt $ affjax $ defaultRequest { url = "/mirror" }) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status

  A.log "GET /does-not-exist: should be 404 Not found"
  (attempt $ affjax $ defaultRequest { url = "/does-not-exist" }) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse String)
    assertEq notFound404 res.status

  A.log "GET /not-json: invalid JSON with Foreign response should throw an error"
  assertLeft =<< attempt (get "/not-json" :: Affjax _ Foreign)

  A.log "GET /not-json: invalid JSON with String response should be ok"
  (attempt $ get "/not-json") >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse String)
    assertEq ok200 res.status

  A.log "POST /mirror: should use the POST method"
  (attempt $ post "/mirror" "test") >>= assertRight >>= \res -> do
    assertEq ok200 res.status
    assertEq "POST" (_.method $ unsafeFromForeign res.response)

  A.log "PUT with a request body"
  let content = "the quick brown fox jumps over the lazy dog"
  (attempt $ put "/mirror" content) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status
    let mirroredReq = unsafeFromForeign res.response
    assertEq "PUT"   mirroredReq.method
    assertEq content mirroredReq.body

  A.log "Testing CORS, HTTPS"
  (attempt $ get "https://cors-test.appspot.com/test") >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status
    -- assertEq (Just "test=test") (lookupHeader "Set-Cookie" res.headers)

  A.log "Testing cancellation"
  canceler <- forkAff (post_ "/mirror" "do it now")
  canceled <- canceler `cancel` error "Pull the cord!"
  assertMsg "Should have been canceled" canceled

module Test.Main where

import Prelude

import Control.Monad.Aff
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (CONSOLE(), log, print)
import qualified Control.Monad.Aff.Console as A
import Control.Monad.Eff.Exception
import Data.Either
import Data.Maybe
import Data.Foreign
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Response
import Network.HTTP.Affjax.Request
import Network.HTTP.Method
import Network.HTTP.MimeType.Common
import Network.HTTP.RequestHeader
import Network.HTTP.StatusCode

foreign import logAny
  :: forall e a. a -> Eff (console :: CONSOLE | e) Unit

logAny' :: forall e a. a -> Assert e Unit
logAny' = liftEff <<< logAny

type Assert e a = Aff (err :: EXCEPTION, console :: CONSOLE, ajax :: AJAX | e) a

assertFail :: forall e a. String -> Assert e a
assertFail msg = let e = error msg
                 in makeAff \errback _ -> errback e

assertMsg :: forall e. String -> Boolean -> Assert e Unit
assertMsg _   true  = return unit
assertMsg msg false = assertFail msg

assertRight :: forall e a b. Either a b -> Assert e b
assertRight x = case x of
  Left y -> logAny' y >>= \_ -> assertFail "Expected a Right value"
  Right y -> return y

assertLeft :: forall e a b. Either a b -> Assert e a
assertLeft x = case x of
  Right y -> logAny' y >>= \_ -> assertFail "Expected a Left value"
  Left y -> return y

assertEq :: forall e a. (Eq a, Show a) => a -> a -> Assert e Unit
assertEq x y = if x == y
                 then return unit
                 else assertFail $ "Expected " <> show x <> ", got " <> show y

-- | For helping type inference
typeIs :: forall e a. a -> Assert e Unit
typeIs = const (return unit)

main = runAff throwException (const $ log "affjax: All good!") $ do
  let ok200 = StatusCode 200
  let notFound404 = StatusCode 404

  assertFail "lol"

  A.log "GET /mirror: should be 200 OK"
  (attempt $ affjax $ defaultRequest { url = "/mirror" }) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status

  A.log "GET /does-not-exist: should be 404 Not found"
  (attempt $ affjax $ defaultRequest { url = "/does-not-exist" }) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse String)
    assertEq notFound404 res.status

  A.log "GET /not-json: invalid JSON with Foreign response should throw an error"
  assertLeft =<< attempt (get "/not-json" :: Affjax _ Foreign)

  A.log "GET /not-json: invalid JSON with String response should be ok"
  (attempt $ get "/not-json") >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse String)
    assertEq ok200 res.status

  A.log "POST /mirror: should use the POST method"
  (attempt $ post "/mirror" "test") >>= assertRight >>= \res -> do
    assertEq ok200 res.status
    assertEq "POST" (_.method $ unsafeFromForeign res.response)

  A.log "PUT with a request body"
  let content = "the quick brown fox jumps over the lazy dog"
  (attempt $ put "/mirror" content) >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status
    let mirroredReq = unsafeFromForeign res.response
    assertEq "PUT"   mirroredReq.method
    assertEq content mirroredReq.body

  A.log "Testing CORS, HTTPS"
  (attempt $ get "https://cors-test.appspot.com/test") >>= assertRight >>= \res -> do
    typeIs (res :: AffjaxResponse Foreign)
    assertEq ok200 res.status
    -- assertEq (Just "test=test") (lookupHeader "Set-Cookie" res.headers)

  A.log "Testing cancellation"
  canceler <- forkAff (post_ "/mirror" "do it now")
  canceled <- canceler `cancel` error "Pull the cord!"
  assertMsg "Should have been canceled" canceled


tmp workaround test/Main to run TyperChecker tests

module Test.Main where

import Prelude (Unit, show, (++), ($), bind, (==), (+))
import Data.List (length)
import Data.Traversable (for)

import Test.Parser as Parser
import Test.Evaluator as Evaluator
import Test.TypeChecker as TypeChecker

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Writer (execWriter)

import Node.Process (PROCESS, exit)

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  log $ "Running parser tests..."
  let parserLog = execWriter Parser.runTests
  log $ "  ...found " ++ show (length parserLog) ++ " errors"
  for parserLog log

  log $ "Running evaluator tests..."
  let evaluatorLog = execWriter Evaluator.runTests
  log $ "  ...found " ++ show (length evaluatorLog) ++ " errors"
  for evaluatorLog log

  TypeChecker.runTests

  let errorCount = length parserLog + length evaluatorLog
  if errorCount == 0
    then do
      log $ "All tests succesfull"
      exit 0
    else do
      log $ "Found " ++ show errorCount ++ " errors!"
      exit 1

module Test.Main where

import Prelude (Unit, show, (++), ($), bind, (==), (+))
import Data.List (length)
import Data.Traversable (for)

import Test.Parser as Parser
import Test.Evaluator as Evaluator
import Test.TypeChecker as TypeChecker

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Writer (execWriter)

import Node.Process (PROCESS, exit)

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  log $ "Running parser tests..."
  let parserLog = execWriter Parser.runTests
  log $ "  ...found " ++ show (length parserLog) ++ " errors"
  for parserLog log

  log $ "Running evaluator tests..."
  let evaluatorLog = execWriter Evaluator.runTests
  log $ "  ...found " ++ show (length evaluatorLog) ++ " errors"
  for evaluatorLog log

  log $ "Running typing tests..."
  let evaluatorLog = execWriter TypeChecker.runTests
  log $ "  ...found " ++ show (length evaluatorLog) ++ " errors"
  for evaluatorLog log

  let errorCount = length parserLog + length evaluatorLog
  if errorCount == 0
    then do
      log $ "All tests succesfull"
      exit 0
    else do
      log $ "Found " ++ show errorCount ++ " errors!"
      exit 1


fixes tests

fixes tests

module Test.Data.Worksheet
       ( worksheetTestSuite
       ) where

import Prelude
import Data.Either (Either(..))
import Test.Unit (Test, TestSuite, suite, test)
import Test.Unit.Assert (equal)

import Data.Worksheet (CalculationResult(..), Worksheet, WorksheetRowResult(..), WorksheetResults, input, calculation, decodeWorksheet, encodeWorksheet, runWorksheet)
import Test.Data.Arbitrary.Identifier (identifier)
import Test.Data.Arbitrary.Formula (formula)

worksheetTestSuite :: forall e. TestSuite e
worksheetTestSuite =
  suite "Worksheet" do

    test "encoding" do
      encodedSimpleWorksheet `equal` (encodeWorksheet simpleWorksheet)

    test "decoding" do
      (Right simpleWorksheet) `equal` (decodeWorksheet encodedSimpleWorksheet)

    test "run calculations" do
      encodedSimpleWorksheet                `calculatesAs` [ Nothing, CalculationResult (Result "53.00") ]
      "i:x:x:26,c:y:y:x%2Fx:0"              `calculatesAs` [ Nothing, CalculationResult (Result  "1") ]
      "i:x:x:12,i:y:y:34,c:z:z:100*x%2By:4" `calculatesAs` [ Nothing, Nothing, CalculationResult (Result $ "1\xa0" <> "234.0000") ]

simpleWorksheet :: Worksheet
simpleWorksheet =
  [ input       "label1"                       (identifier "x")  42.0
  , calculation "label:with:colons,and,commas" (identifier "_y") (formula "x + 11") 2
  ]

encodedSimpleWorksheet :: String
encodedSimpleWorksheet = "i:label1:x:42.0,c:label%3Awith%3Acolons%2Cand%2Ccommas:_y:x%2B11.0:2"

calculatesAs :: forall e. String -> WorksheetResults -> Test e
calculatesAs encoded expected =
  (Right expected) `equal` (runWorksheet <$> decodeWorksheet encoded)

module Test.Data.Worksheet
       ( worksheetTestSuite
       ) where

import Prelude
import Data.Either (Either(..))
import Test.Unit (Test, TestSuite, suite, test)
import Test.Unit.Assert (equal)

import Data.Worksheet (CalculationResult(..), Worksheet, WorksheetRowResult(..), WorksheetResults, input, calculation, decodeWorksheet, encodeWorksheet, runWorksheet)
import Test.Data.Arbitrary.Identifier (identifier)
import Test.Data.Arbitrary.Formula (formula)

worksheetTestSuite :: forall e. TestSuite e
worksheetTestSuite =
  suite "Worksheet" do

    test "encoding" do
      encodedSimpleWorksheet `equal` (encodeWorksheet simpleWorksheet)

    test "decoding" do
      (Right simpleWorksheet) `equal` (decodeWorksheet encodedSimpleWorksheet)

    test "run calculations" do
      encodedSimpleWorksheet                `calculatesAs` [ Nothing, CalculationResult (Result "53.0") ]
      "i:x:x:26,c:y:y:x%2Fx:0"              `calculatesAs` [ Nothing, CalculationResult (Result  "1.0") ]
      "i:x:x:12,i:y:y:34,c:z:z:100*x%2By:0" `calculatesAs` [ Nothing, Nothing, CalculationResult (Result "1234.0") ]

simpleWorksheet :: Worksheet
simpleWorksheet =
  [ input       { label: "label1",                       identifier: identifier "x",  value: 42.0 }
  , calculation { label: "label:with:colons,and,commas", identifier: identifier "_y", formula: formula "x + 11", precision: 2 }
  ]

encodedSimpleWorksheet :: String
encodedSimpleWorksheet = "i:label1:x:42.0,c:label%3Awith%3Acolons%2Cand%2Ccommas:_y:x%2B11.0:2"

calculatesAs :: forall e. String -> WorksheetResults -> Test e
calculatesAs encoded expected =
  (Right expected) `equal` (runWorksheet <$> decodeWorksheet encoded)


Hide constructor

Hide constructor

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)
import Control.Monad.State.Trans (StateT)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Identity (Identity)
import Data.Int (toNumber)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math as M

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (StateT GenState Identity a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x) xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen(..)
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)
import Control.Monad.State.Trans (StateT)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Identity (Identity)
import Data.Int (toNumber)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math as M

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (StateT GenState Identity a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x) xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen


Fix title of Halogen 4.0.0 implementation.

module Main where

import Prelude

import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Console (log)
import Effect.Random (randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import DOM.HTML.Indexed.ButtonType (ButtonType(..))
import Data.Array (cons, deleteAt, findIndex, index, length, mapWithIndex, updateAt, (!!))
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)

-----------
-- Main Entry

-- Start and run the application
main :: Effect Unit
main = HA.runHalogenAff $ do
  body <- HA.awaitBody
  runUI app unit body

-- The top level component to render to the <body> element
app :: H.Component HH.HTML Query Unit Void Aff
app =
  H.component
    { initialState: const init
    , render
    , eval
    , receiver: const Nothing
    }

----------
-- State

type State =
  { rows     :: Array Row
  , selected :: Maybe Int
  , lastId   :: Int }

type Row =
  { rid        :: Int
  , label      :: String }

init :: State
init =
  { rows: [], selected: Nothing, lastId: 1 }

----------
-- Queries

data Query a
  = Create Int a
  | Append Int a
  | UpdateEvery Int a
  | Clear a
  | Swap Int Int a
  | Remove Int a
  | Select Int a

eval :: Query ~> H.ComponentDSL State Query Void Aff
eval = case _ of

  Clear next -> do
    H.modify_ (\st -> st { rows = [], lastId = st.lastId })
    pure next

  Create i next -> do
    st   <- H.get
    rows <- H.liftEffect $ createRandomNRows i st.lastId
    H.modify_ (\st' -> st' { rows = rows, lastId = st'.lastId + i })
    pure next

  Append i next -> do
    st   <- H.get
    rows <- H.liftEffect $ createRandomNRows i st.lastId
    H.modify_ (\st' -> st' { rows = st'.rows <> rows, lastId = st'.lastId + i})
    pure next

  UpdateEvery i next -> do
    st  <- H.get
    let rows = mapWithIndex (updateRowLabel i) st.rows
    H.modify_ (\st' -> st' { rows = rows } )
    pure next

  Swap i0 i1 next -> do
    st <- H.get
    case swapRows st.rows i0 i1 of
      Nothing  ->
        H.liftEffect $ log "Failed to swap rows."
      Just arr ->
        H.modify_ (\st' -> st' { rows = arr })
    pure next

  -- If the row is already selected, deselect, else set it as the selected row.
  Select i next -> do
    st <- H.get
    H.modify_ (\st' -> st' { selected = if (Just i) == st'.selected then Nothing else Just i })
    pure next

  Remove i next -> do
    st <- H.get
    H.modify_ (\st' -> st' { rows = deleteRow i st'.rows })
    pure next

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: Int -> Int -> Effect (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n' = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n' - 1) lastId str')
                   , b: (n' - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
   , label: s })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: Effect (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB arr
  arrB <- updateAt index2 rowA arrA

  pure arrB

----------
-- Rendering Views

render :: State -> H.ComponentHTML Query
render state =
  let
    label = show state.lastId
  in
    HH.div
      [ HP.classes [ HH.ClassName "container" ] ]
      [ HH.div
        [ HP.classes [ HH.ClassName "jumbotron" ] ]
        [ HH.div
          [ HP.classes [ HH.ClassName "row" ] ]
          [ HH.div
            [ HP.classes [ HH.ClassName "col-md-6" ] ]
            [ HH.h1_
              [ HH.text "Halogen 4.0.0" ] ]
          , HH.div
            [ HP.classes [ HH.ClassName "col-md-6" ] ]
            $ map renderButton buttons
          ]
        ]
      , HH.table
        [ HP.classes [ HH.ClassName "table table-hover table-striped test-data" ] ]
        [ HH.tbody_
          $ map (renderRow state.selected) state.rows ]
      ,  HH.span
        [ HP.classes [ HH.ClassName "preloadicon glyphicon glyphicon-remove" ]
          , HP.attr (HH.AttrName "aria-hidden") "true" ]
        [ HH.text "" ]
      ]

renderRow :: Maybe Int -> Row -> H.ComponentHTML Query
renderRow mi { rid, label } =
  let
    checkSelected =
      case mi of
        Nothing -> HH.tr_
        Just i  ->
          if rid == i
          then HH.tr [ HP.classes [ HH.ClassName "danger"]
                     , HP.attr (HH.AttrName "selected") "true" ]
          else HH.tr_
  in
   checkSelected
     [
       HH.td
         [ HP.classes [ HH.ClassName "col-md-1" ] ]
         [ HH.text $ show rid ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-4" ] ]
         [ HH.a
           [ HP.href "#", HE.onClick (HE.input_ $ Select rid) ]
           [ HH.text label ] ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-1" ] ]
         [ HH.a
           [ HP.href "#" ]
           [ HH.span
             [ HP.classes [ HH.ClassName "glyphicon glyphicon-remove" ]
             , HP.attr (HH.AttrName "aria-hidden") "true"
             , HE.onClick (HE.input_ $ Remove rid) ]
             [ HH.text "" ] ] ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-6" ] ]
         [ HH.text "" ]
     ]

renderButton ::
  { bid :: String, str :: String, q :: (Unit -> Query Unit) }
  -> H.ComponentHTML Query
renderButton { bid, str, q } =
  HH.div
    [ HP.classes [ HH.ClassName "col-sm-6 smallpad" ] ]
    [ HH.button
      [ HP.type_ ButtonButton
      , HP.classes [ HH.ClassName "btn btn-primary btn-block" ]
      , HP.id_ bid
      , HE.onClick (HE.input_ q) ]
      [ HH.text str ]
    ]

buttons :: Array { bid :: String, str :: String, q :: (Unit -> Query Unit) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     q: Create 1000    }
  , { bid: "runlots",  str: "Create 10,000 Rows",    q: Create 10000   }
  , { bid: "add",      str: "Append 1,000 Rows",     q: Append 1000    }
  , { bid: "update",   str: "Update Every 10th Row", q: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 q: Clear          }
  , { bid: "swaprows", str: "Swap Rows",             q: Swap 1 998     } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]

module Main where

import Prelude

import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Console (log)
import Effect.Random (randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import DOM.HTML.Indexed.ButtonType (ButtonType(..))
import Data.Array (cons, deleteAt, findIndex, index, length, mapWithIndex, updateAt, (!!))
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)

-----------
-- Main Entry

-- Start and run the application
main :: Effect Unit
main = HA.runHalogenAff $ do
  body <- HA.awaitBody
  runUI app unit body

-- The top level component to render to the <body> element
app :: H.Component HH.HTML Query Unit Void Aff
app =
  H.component
    { initialState: const init
    , render
    , eval
    , receiver: const Nothing
    }

----------
-- State

type State =
  { rows     :: Array Row
  , selected :: Maybe Int
  , lastId   :: Int }

type Row =
  { rid        :: Int
  , label      :: String }

init :: State
init =
  { rows: [], selected: Nothing, lastId: 1 }

----------
-- Queries

data Query a
  = Create Int a
  | Append Int a
  | UpdateEvery Int a
  | Clear a
  | Swap Int Int a
  | Remove Int a
  | Select Int a

eval :: Query ~> H.ComponentDSL State Query Void Aff
eval = case _ of

  Clear next -> do
    H.modify_ (\st -> st { rows = [], lastId = st.lastId })
    pure next

  Create i next -> do
    st   <- H.get
    rows <- H.liftEffect $ createRandomNRows i st.lastId
    H.modify_ (\st' -> st' { rows = rows, lastId = st'.lastId + i })
    pure next

  Append i next -> do
    st   <- H.get
    rows <- H.liftEffect $ createRandomNRows i st.lastId
    H.modify_ (\st' -> st' { rows = st'.rows <> rows, lastId = st'.lastId + i})
    pure next

  UpdateEvery i next -> do
    st  <- H.get
    let rows = mapWithIndex (updateRowLabel i) st.rows
    H.modify_ (\st' -> st' { rows = rows } )
    pure next

  Swap i0 i1 next -> do
    st <- H.get
    case swapRows st.rows i0 i1 of
      Nothing  ->
        H.liftEffect $ log "Failed to swap rows."
      Just arr ->
        H.modify_ (\st' -> st' { rows = arr })
    pure next

  -- If the row is already selected, deselect, else set it as the selected row.
  Select i next -> do
    st <- H.get
    H.modify_ (\st' -> st' { selected = if (Just i) == st'.selected then Nothing else Just i })
    pure next

  Remove i next -> do
    st <- H.get
    H.modify_ (\st' -> st' { rows = deleteRow i st'.rows })
    pure next

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: Int -> Int -> Effect (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n' = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n' - 1) lastId str')
                   , b: (n' - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
   , label: s })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: Effect (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB arr
  arrB <- updateAt index2 rowA arrA

  pure arrB

----------
-- Rendering Views

render :: State -> H.ComponentHTML Query
render state =
  let
    label = show state.lastId
  in
    HH.div
      [ HP.classes [ HH.ClassName "container" ] ]
      [ HH.div
        [ HP.classes [ HH.ClassName "jumbotron" ] ]
        [ HH.div
          [ HP.classes [ HH.ClassName "row" ] ]
          [ HH.div
            [ HP.classes [ HH.ClassName "col-md-6" ] ]
            [ HH.h1_
              [ HH.text "Halogen 2.1.0" ] ]
          , HH.div
            [ HP.classes [ HH.ClassName "col-md-6" ] ]
            $ map renderButton buttons
          ]
        ]
      , HH.table
        [ HP.classes [ HH.ClassName "table table-hover table-striped test-data" ] ]
        [ HH.tbody_
          $ map (renderRow state.selected) state.rows ]
      ,  HH.span
        [ HP.classes [ HH.ClassName "preloadicon glyphicon glyphicon-remove" ]
          , HP.attr (HH.AttrName "aria-hidden") "true" ]
        [ HH.text "" ]
      ]

renderRow :: Maybe Int -> Row -> H.ComponentHTML Query
renderRow mi { rid, label } =
  let
    checkSelected =
      case mi of
        Nothing -> HH.tr_
        Just i  ->
          if rid == i
          then HH.tr [ HP.classes [ HH.ClassName "danger"]
                     , HP.attr (HH.AttrName "selected") "true" ]
          else HH.tr_
  in
   checkSelected
     [
       HH.td
         [ HP.classes [ HH.ClassName "col-md-1" ] ]
         [ HH.text $ show rid ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-4" ] ]
         [ HH.a
           [ HP.href "#", HE.onClick (HE.input_ $ Select rid) ]
           [ HH.text label ] ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-1" ] ]
         [ HH.a
           [ HP.href "#" ]
           [ HH.span
             [ HP.classes [ HH.ClassName "glyphicon glyphicon-remove" ]
             , HP.attr (HH.AttrName "aria-hidden") "true"
             , HE.onClick (HE.input_ $ Remove rid) ]
             [ HH.text "" ] ] ]
     , HH.td
         [ HP.classes [ HH.ClassName "col-md-6" ] ]
         [ HH.text "" ]
     ]

renderButton ::
  { bid :: String, str :: String, q :: (Unit -> Query Unit) }
  -> H.ComponentHTML Query
renderButton { bid, str, q } =
  HH.div
    [ HP.classes [ HH.ClassName "col-sm-6 smallpad" ] ]
    [ HH.button
      [ HP.type_ ButtonButton
      , HP.classes [ HH.ClassName "btn btn-primary btn-block" ]
      , HP.id_ bid
      , HE.onClick (HE.input_ q) ]
      [ HH.text str ]
    ]

buttons :: Array { bid :: String, str :: String, q :: (Unit -> Query Unit) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     q: Create 1000    }
  , { bid: "runlots",  str: "Create 10,000 Rows",    q: Create 10000   }
  , { bid: "add",      str: "Append 1,000 Rows",     q: Append 1000    }
  , { bid: "update",   str: "Update Every 10th Row", q: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 q: Clear          }
  , { bid: "swaprows", str: "Swap Rows",             q: Swap 1 998     } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]


Update for PureScript 0.13.0

Update for PureScript 0.13.0

module Test.Input
  ( CodePoint(..)
  , NegativeInt(..)
  , NewlineChar(..)
  , NonNegativeInt(..)
  , SurrogateCodePoint(..)
  , WhiteSpaceChar(..)
  , OneCharString(..)
  )
where

import Data.List                  (List, fromFoldable)
import Prelude
import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.StrongCheck.Gen       (chooseInt, elements)
import Unsafe.Coerce              (unsafeCoerce)

newtype CodePoint          = CodePoint Int
newtype NegativeInt        = NegativeInt Int
newtype NewlineChar        = NewlineChar Char
newtype NonNegativeInt     = NonNegativeInt Int
newtype SurrogateCodePoint = SurrogateCodePoint Int
newtype WhiteSpaceChar     = WhiteSpaceChar Char
newtype OneCharString      = OneCharString String

-- Unicode code points are in the range 0 .. U+10FFFF
instance arbCodePoint :: Arbitrary CodePoint where
  arbitrary = CodePoint <$> chooseInt 0 0x10FFFF

instance arbNegativeInt :: Arbitrary NegativeInt where
  arbitrary = NegativeInt <$> chooseInt (-2147483648) (-1)

instance arbNewlineChar :: Arbitrary NewlineChar where
  arbitrary = NewlineChar <$> elements '\n' newlineChars

instance arbNonNegativeInt :: Arbitrary NonNegativeInt where
  arbitrary = NonNegativeInt <$> chooseInt 0 2147483647

-- Surrogate code points are in the range U+D800 .. U+DFFF
instance arbSurrogateCodePoint :: Arbitrary SurrogateCodePoint where
  arbitrary = SurrogateCodePoint <$> chooseInt 0xD800 0xDFFF

instance arbWhiteSpaceChar :: Arbitrary WhiteSpaceChar where
  arbitrary = WhiteSpaceChar <$> elements ' ' whiteSpaceChars

instance arbOneCharString :: Arbitrary OneCharString where
  arbitrary = OneCharString <<< (unsafeCoerce :: Char -> String) <$> arbitrary

newlineChars :: List Char
newlineChars = fromFoldable
  [ '\n', '\r', '\x0085', '\x2028', '\x2029' ]

whiteSpaceChars :: List Char
whiteSpaceChars = fromFoldable
  [ ' ', '\n', '\r', '\t', '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002'
  , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007', '\x2008', '\x2009'
  , '\x200A', '\x2028', '\x2029', '\x202F', '\x205F', '\x3000', '\xFEFF'
  ]

module Test.Input
  ( CodePoint(..)
  , NegativeInt(..)
  , NewlineChar(..)
  , NonNegativeInt(..)
  , SurrogateCodePoint(..)
  , WhiteSpaceChar(..)
  , OneCharString(..)
  )
where

import Data.List                  (List, fromFoldable)
import Prelude
import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.StrongCheck.Gen       (chooseInt, elements)
import Unsafe.Coerce              (unsafeCoerce)

newtype CodePoint          = CodePoint Int
newtype NegativeInt        = NegativeInt Int
newtype NewlineChar        = NewlineChar Char
newtype NonNegativeInt     = NonNegativeInt Int
newtype SurrogateCodePoint = SurrogateCodePoint Int
newtype WhiteSpaceChar     = WhiteSpaceChar Char
newtype OneCharString      = OneCharString String

-- Unicode code points are in the range 0 .. U+10FFFF
instance arbCodePoint :: Arbitrary CodePoint where
  arbitrary = CodePoint <$> chooseInt 0 0x10FFFF

instance arbNegativeInt :: Arbitrary NegativeInt where
  arbitrary = NegativeInt <$> chooseInt (-2147483648) (-1)

instance arbNewlineChar :: Arbitrary NewlineChar where
  arbitrary = NewlineChar <$> elements '\n' newlineChars

instance arbNonNegativeInt :: Arbitrary NonNegativeInt where
  arbitrary = NonNegativeInt <$> chooseInt 0 2147483647

-- Surrogate code points are in the range U+D800 .. U+DFFF
instance arbSurrogateCodePoint :: Arbitrary SurrogateCodePoint where
  arbitrary = SurrogateCodePoint <$> chooseInt 0xD800 0xDFFF

instance arbWhiteSpaceChar :: Arbitrary WhiteSpaceChar where
  arbitrary = WhiteSpaceChar <$> elements ' ' whiteSpaceChars

instance arbOneCharString :: Arbitrary OneCharString where
  arbitrary = OneCharString <<< (unsafeCoerce :: Char -> String) <$> arbitrary

newlineChars :: List Char
newlineChars = fromFoldable
  [ '\n', '\v', '\f', '\r', '\x0085', '\x2028', '\x2029' ]

whiteSpaceChars :: List Char
whiteSpaceChars = fromFoldable
  [ ' ', '\f', '\n', '\r', '\t', '\v', '\x00A0', '\x1680', '\x2000', '\x2001'
  , '\x2002', '\x2003', '\x2004', '\x2005', '\x2006', '\x2007', '\x2008'
  , '\x2009', '\x200A', '\x2028', '\x2029', '\x202F', '\x205F', '\x3000'
  , '\xFEFF'
  ]