readonly -> readOnly

readonly -> readOnly

-- | This module provides `Prop` values for some common HTML attributes.
module Halogen.HTML.Properties
  ( key
  , alt
  , charset
  , class_
  , classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , required
  , readonly
  , spellcheck
  , enabled
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , initializer
  , finalizer
  , LengthLiteral(..)
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.String (joinWith)

import DOM.HTML.Types (HTMLElement())

import Halogen.HTML.Core (Prop(..), ClassName(), IsProp, prop, propName, attrName, runClassName)

data LengthLiteral
  = Pixels Int
  | Percent Number

printLengthLiteral :: LengthLiteral -> String
printLengthLiteral (Pixels n) = show n
printLengthLiteral (Percent n) = show n ++ "%"

-- | 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 -> Prop i
key = Key

alt :: forall i. String -> Prop i
alt = prop (propName "alt") (Just $ attrName "alt")

charset :: forall i. String -> Prop i
charset = prop (propName "charset") (Just $ attrName "charset")

class_ :: forall i. ClassName -> Prop i
class_ = prop (propName "className") (Just $ attrName "class") <<< runClassName

classes :: forall i. Array ClassName -> Prop i
classes = prop (propName "className") (Just $ attrName "class") <<< joinWith " " <<< map runClassName

cols :: forall i. Int -> Prop i
cols = prop (propName "cols") (Just $ attrName "cols")

rows :: forall i. Int -> Prop i
rows = prop (propName "rows") (Just $ attrName "rows")

colSpan :: forall i. Int -> Prop i
colSpan = prop (propName "colSpan") (Just $ attrName "colspan")

rowSpan :: forall i. Int -> Prop i
rowSpan = prop (propName "rowSpan") (Just $ attrName "rowspan")

for :: forall i. String -> Prop i
for = prop (propName "htmlFor") (Just $ attrName "for")

height :: forall i. LengthLiteral -> Prop i
height = prop (propName "height") (Just $ attrName "height") <<< printLengthLiteral

href :: forall i. String -> Prop i
href = prop (propName "href") (Just $ attrName "href")

id_ :: forall i. String -> Prop i
id_ = prop (propName "id") (Just $ attrName "id")

name :: forall i. String -> Prop i
name = prop (propName "name") (Just $ attrName "name")

rel :: forall i. String -> Prop i
rel = prop (propName "rel") (Just $ attrName "rel")

src :: forall i. String -> Prop i
src = prop (propName "src") (Just $ attrName "src")

target :: forall i. String -> Prop i
target = prop (propName "target") (Just $ attrName "target")

title :: forall i. String -> Prop i
title = prop (propName "title") (Just $ attrName "title")

type_ :: forall i. String -> Prop i
type_ = prop (propName "type") (Just $ attrName "type")

-- TODO: string rendering of `value` will need custom handling depending on element type
value :: forall i. String -> Prop i
value = prop (propName "value") (Just $ attrName "value")

width :: forall i. LengthLiteral -> Prop i
width = prop (propName "width") (Just $ attrName "width") <<< printLengthLiteral

disabled :: forall i. Boolean -> Prop i
disabled = prop (propName "disabled") (Just $ attrName "disabled")

required :: forall i. Boolean -> Prop i
required = prop (propName "required") (Just $ attrName "required")

readonly :: forall i. Boolean -> Prop i
readonly = prop (propName "readOnly") (Just $ attrName "readonly")

spellcheck :: forall i. Boolean -> Prop i
spellcheck = prop (propName "spellcheck") (Just $ attrName "spellcheck")

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

checked :: forall i. Boolean -> Prop i
checked = prop (propName "checked") (Just $ attrName "checked")

selected :: forall i. Boolean -> Prop i
selected = prop (propName "selected") (Just $ attrName "selected")

placeholder :: forall i. String -> Prop i
placeholder = prop (propName "placeholder") (Just $ attrName "placeholder")

autocomplete :: forall i. Boolean -> Prop i
autocomplete = prop (propName "autocomplete") (Just $ attrName "autocomplete") <<< (\b -> if b then "on" else "off")

autofocus :: forall i. Boolean -> Prop i
autofocus = prop (propName "autofocus") (Just $ attrName "autofocus")

initializer :: forall i. (HTMLElement -> i) -> Prop i
initializer = Initializer

finalizer :: forall i. (HTMLElement -> i) -> Prop i
finalizer = Finalizer

-- | This module provides `Prop` values for some common HTML attributes.
module Halogen.HTML.Properties
  ( key
  , alt
  , charset
  , class_
  , classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , required
  , readonly
  , spellcheck
  , enabled
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , initializer
  , finalizer
  , LengthLiteral(..)
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.String (joinWith)

import DOM.HTML.Types (HTMLElement())

import Halogen.HTML.Core (Prop(..), ClassName(), IsProp, prop, propName, attrName, runClassName)

data LengthLiteral
  = Pixels Int
  | Percent Number

printLengthLiteral :: LengthLiteral -> String
printLengthLiteral (Pixels n) = show n
printLengthLiteral (Percent n) = show n ++ "%"

-- | 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 -> Prop i
key = Key

alt :: forall i. String -> Prop i
alt = prop (propName "alt") (Just $ attrName "alt")

charset :: forall i. String -> Prop i
charset = prop (propName "charset") (Just $ attrName "charset")

class_ :: forall i. ClassName -> Prop i
class_ = prop (propName "className") (Just $ attrName "class") <<< runClassName

classes :: forall i. Array ClassName -> Prop i
classes = prop (propName "className") (Just $ attrName "class") <<< joinWith " " <<< map runClassName

cols :: forall i. Int -> Prop i
cols = prop (propName "cols") (Just $ attrName "cols")

rows :: forall i. Int -> Prop i
rows = prop (propName "rows") (Just $ attrName "rows")

colSpan :: forall i. Int -> Prop i
colSpan = prop (propName "colSpan") (Just $ attrName "colspan")

rowSpan :: forall i. Int -> Prop i
rowSpan = prop (propName "rowSpan") (Just $ attrName "rowspan")

for :: forall i. String -> Prop i
for = prop (propName "htmlFor") (Just $ attrName "for")

height :: forall i. LengthLiteral -> Prop i
height = prop (propName "height") (Just $ attrName "height") <<< printLengthLiteral

href :: forall i. String -> Prop i
href = prop (propName "href") (Just $ attrName "href")

id_ :: forall i. String -> Prop i
id_ = prop (propName "id") (Just $ attrName "id")

name :: forall i. String -> Prop i
name = prop (propName "name") (Just $ attrName "name")

rel :: forall i. String -> Prop i
rel = prop (propName "rel") (Just $ attrName "rel")

src :: forall i. String -> Prop i
src = prop (propName "src") (Just $ attrName "src")

target :: forall i. String -> Prop i
target = prop (propName "target") (Just $ attrName "target")

title :: forall i. String -> Prop i
title = prop (propName "title") (Just $ attrName "title")

type_ :: forall i. String -> Prop i
type_ = prop (propName "type") (Just $ attrName "type")

-- TODO: string rendering of `value` will need custom handling depending on element type
value :: forall i. String -> Prop i
value = prop (propName "value") (Just $ attrName "value")

width :: forall i. LengthLiteral -> Prop i
width = prop (propName "width") (Just $ attrName "width") <<< printLengthLiteral

disabled :: forall i. Boolean -> Prop i
disabled = prop (propName "disabled") (Just $ attrName "disabled")

required :: forall i. Boolean -> Prop i
required = prop (propName "required") (Just $ attrName "required")

readonly :: forall i. Boolean -> Prop i
readonly = prop (propName "readonly") (Just $ attrName "readonly")

spellcheck :: forall i. Boolean -> Prop i
spellcheck = prop (propName "spellcheck") (Just $ attrName "spellcheck")

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

checked :: forall i. Boolean -> Prop i
checked = prop (propName "checked") (Just $ attrName "checked")

selected :: forall i. Boolean -> Prop i
selected = prop (propName "selected") (Just $ attrName "selected")

placeholder :: forall i. String -> Prop i
placeholder = prop (propName "placeholder") (Just $ attrName "placeholder")

autocomplete :: forall i. Boolean -> Prop i
autocomplete = prop (propName "autocomplete") (Just $ attrName "autocomplete") <<< (\b -> if b then "on" else "off")

autofocus :: forall i. Boolean -> Prop i
autofocus = prop (propName "autofocus") (Just $ attrName "autofocus")

initializer :: forall i. (HTMLElement -> i) -> Prop i
initializer = Initializer

finalizer :: forall i. (HTMLElement -> i) -> Prop i
finalizer = Finalizer


Work around compiler bug - use gDefaultToURLPiece

directly.

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (gDefaultToURLPiece, SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem opts'@(SPSettings_ opts) fName val = fName <> "=" <> encodeURLPiece opts' val

-- | Call opts.toURLPiece and encode the resulting string with encodeURIComponent.
encodeURLPiece :: forall a params. Generic a => SPSettings_ params -> a -> String
encodeURLPiece (SPSettings_ opts) = encodeURIComponent <<< gDefaultToURLPiece

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem opts'@(SPSettings_ opts) fName val = fName <> "=" <> encodeURLPiece opts' val

-- | Call opts.toURLPiece and encode the resulting string with encodeURIComponent.
encodeURLPiece :: forall a params. Generic a => SPSettings_ params -> a -> String
encodeURLPiece (SPSettings_ opts) = encodeURIComponent <<< unsafeCoerce opts.toURLPiece

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"


Commented out slow tests

Commented out slow tests

module Test.Benchmarks (benchmarks) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Array as A
import Data.Maybe (fromMaybe)
import Node.FS.Sync (readTextFile)
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Control.Monad.Eff.Exception (EXCEPTION)

import Test.Assert (assert, ASSERT)

import Data.TimeSeries as TS
import Data.TimeSeries.IO as IO

benchmarks :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS | eff) Unit
benchmarks = do

    log "\n# Benchmark tests"
    log "Load 60k Time Series from the file"
    csv <- readTextFile UTF8 "testdata/test60k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    -- let s3 = TS.zipWith (==) s1 s2
    -- log $ show (A.length s3.values)
    assert $ (A.length s1.values) == 59042

module Test.Benchmarks (benchmarks) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Array as A
import Data.Maybe (fromMaybe)
import Node.FS.Sync (readTextFile)
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Control.Monad.Eff.Exception (EXCEPTION)

import Test.Assert (assert, ASSERT)

import Data.TimeSeries as TS
import Data.TimeSeries.IO as IO

benchmarks :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS | eff) Unit
benchmarks = do

    log "\n# Benchmark tests"
    log "Load 60k Time Series from the file"
    csv <- readTextFile UTF8 "testdata/test60k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    let s3 = TS.zipWith (==) s1 s2
    log $ show (A.length s3.values)
    assert $ (A.length s1.values) == 59042


6.9  Write an instance Action m a => Action m (Array a), where the action on arrays is defined by acting on the elements independently.

module Solution where

import Prelude
import Data.Maybe
import Data.Array
import Data.Foldable
import Data.Monoid

newtype Complex = Complex
 { real :: Number
 , imaginary :: Number
 }

instance showComlex :: Show Complex where
  show (Complex c) = "Complex (" ++ show c.real ++ "+i" ++ show c.imaginary ++ ")"

instance eqComlex :: Eq Complex where
  eq (Complex c1) (Complex c2) = c1.real == c2.real && c1.imaginary == c2.imaginary

data NonEmpty a = NonEmpty a (Array a)

instance semigroupNonEmpty :: Semigroup (NonEmpty a) where
  append (NonEmpty a1 array1) (NonEmpty a2 array2 )= NonEmpty a1 ( array1 <> (a2 : array2))

instance semigroupFunctor :: Functor NonEmpty where
  map mapFunction (NonEmpty a array )= NonEmpty (mapFunction a) (mapFunction <$> array)

instance showNonempty :: (Show a) => Show (NonEmpty a) where
  show (NonEmpty a array) = "Nonempty (" ++ show (a:array)  ++ ")"

instance foldableNonEmpty :: Foldable NonEmpty where
  --foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldr abb b  (NonEmpty a array) = abb a (foldr abb b array)
  --foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldl bab b  (NonEmpty a array) = foldl bab (bab b a) array
  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance eqNonempty :: (Eq a) => Eq (NonEmpty a) where
  eq (NonEmpty a1 array1) (NonEmpty a2 array2)  =
    a1 == a2 && array1 == array2

data Extended a = Finite a | Infinite

instance eqExtended :: (Eq a) => Eq (Extended a) where
  --compare :: a -> a -> Ordering
  eq Infinite Infinite  = true
  eq Infinite _  = false
  eq _ Infinite  = false
  eq (Finite a1) (Finite a2)  = a1 == a2

instance ordExtended :: (Ord a) => Ord (Extended a) where
  --compare :: a -> a -> Ordering
  compare Infinite Infinite  = EQ
  compare Infinite _  = GT
  compare _ Infinite  = LT
  compare (Finite a1) (Finite a2)  = compare a1  a2

data OneMore f a = OneMore a (f a)

instance foldableOneMore :: (Foldable f) => Foldable (OneMore f) where
  --foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldr abb b  (OneMore a array) = abb a (foldr abb b array)
  --foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldl bab b  (OneMore a array) = foldl bab (bab b a) array
  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

class (Monoid m) <= Action m a where
 act :: m -> a -> a

--instance repeatAction :: Action Int String where
--  act 0 _ = ""
-- act n s = s ++ act (n - 1) s

instance arrayAction :: (Action m a, Monoid m) =>  Action m (Array a) where
 act m array = map (act m) array


Remove dead code in test/Main

Remove dead code in test/Main

module Test.Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Prelude (Unit, discard)
import Test.Authentication (authenticationSpec)
import Test.Authorization (authorizationSpec)
import Test.DataSnapshotSpec (dataSnapshotSpec)
import Test.RefSpec (refSpec)
import Test.Spec (Spec)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Web.Firebase.Types (FirebaseEff)
import Web.Firebase.Types as FBT

root :: String
root =  "https://purescript-spike.firebaseio.com/"

type FbSpecEffects e = (err :: EXCEPTION, firebase :: FirebaseEff | e)
type FbSpecRunnerEffects e = RunnerEffects (FbSpecEffects e)

main ::  forall eff. Eff (FbSpecRunnerEffects eff) Unit
main = do
  run [consoleReporter] allSpecs

--allSpecs :: forall eff. StateT (Array (Group (Aff (FbSpecEffects eff) Unit))) Identity Unit
allSpecs :: forall t31.
  Spec ( firebase :: FBT.FirebaseEff
                 | t31
       ) Unit
allSpecs  = do
  authorizationSpec
  authenticationSpec
  refSpec root
  dataSnapshotSpec

module Test.Main where

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.State.Trans (StateT(..))
import Control.Monad.Trans.Class (lift)
import Data.Identity (Identity(..))
import Node.Process (PROCESS)
import Prelude (Unit, bind, ($), discard, (>>=))
import Test.Authentication (authenticationSpec)
import Test.Authorization (authorizationSpec)
import Test.DataSnapshotSpec (dataSnapshotSpec)
import Test.RefSpec (refSpec)
import Test.Spec (Group, Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Web.Firebase as FB
import Web.Firebase.Aff.Read (onceValue)
import Web.Firebase.Types (FirebaseEff)
import Web.Firebase.Types as FBT
import Web.Firebase.UnsafeRef (refFor, unsafeRef)

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

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

-- | Determines the name of the database to use for testing
-- Change this when you want tests to run against another database
rootRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
rootRef = refFor "https://purescript-spike.firebaseio.com/"

root :: String
root =  "https://purescript-spike.firebaseio.com/"

-- | Reference to /entries that can be written to and read from
-- It is clearest if each test suite uses its own child path
-- so that after a test run data written can be easily inspected
-- if necessary
entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries"

forbiddenRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
forbiddenRef = refFor "https://purescript-spike.firebaseio.com/forbidden"
-- Console, timer, avar, process

type FbSpecEffects e = (err :: EXCEPTION, firebase :: FirebaseEff | e)
type FbSpecRunnerEffects e = RunnerEffects (FbSpecEffects e)

main ::  forall eff. Eff (FbSpecRunnerEffects eff) Unit
main = do
  run [consoleReporter] allSpecs

--allSpecs :: forall eff. StateT (Array (Group (Aff (FbSpecEffects eff) Unit))) Identity Unit
allSpecs :: forall t31.
  Spec ( firebase :: FBT.FirebaseEff
                 | t31
       ) Unit
allSpecs  = do
  authorizationSpec
  authenticationSpec
  refSpec root
  dataSnapshotSpec


Fix wrong NullOrUndefined test

Fix wrong NullOrUndefined test

module Test.Main where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, isRight)
import Data.Foreign (MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.StrMap (StrMap)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
roundtrips _ enc0 = do
  let dec0 :: E a
      dec0 = handleJSON enc0
      enc1 = either (const "bad1") writeJSON dec0
      json0 :: Either String Json
      json0 = jsonParser enc0
      json1 :: Either String Json
      json1 = jsonParser enc1
      dec1 :: E a
      dec1 = handleJSON enc1
      enc2 = either (const "bad2") writeJSON dec1
  when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
  when (enc1 /= enc2) $ fail enc0

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      isRight (result :: E MyTest) `shouldEqual` false
  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """

module Test.Main where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, isRight)
import Data.Foreign (MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.StrMap (StrMap)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
roundtrips _ enc0 = do
  let dec0 :: E a
      dec0 = handleJSON enc0
      enc1 = either (const "bad1") writeJSON dec0
      json0 :: Either String Json
      json0 = jsonParser enc0
      json1 :: Either String Json
      json1 = jsonParser enc1
      dec1 :: E a
      dec1 = handleJSON enc1
      enc2 = either (const "bad2") writeJSON dec1
  when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
  when (enc1 /= enc2) $ fail enc0

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      isRight (result :: E MyTest) `shouldEqual` false
  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """


Test that FS.Sync.stat exceptions can be caught

module Test where

import Prelude
import Data.Maybe
import Data.Either
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad (unless)
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Console (log)
import Node.Encoding
import qualified Node.Buffer as Buffer
import qualified Node.Path as Path
import Unsafe.Coerce

import Node.FS
import Node.FS.Stats
import qualified Node.FS.Async as A
import qualified Node.FS.Sync as S

-- Cheat to allow `main` to type check. See also issue #5 in
-- purescript-exceptions.
catchException' ::
  forall a eff.
    (Error -> Eff (err :: EXCEPTION | eff) a)
    -> Eff (err :: EXCEPTION | eff) a
    -> Eff (err :: EXCEPTION | eff) a
catchException' = unsafeCoerce catchException

main = do
  let fp = Path.concat

  A.exists (fp ["test", "Test.purs"]) $ \e ->
    log $ "Test.purs exists? " ++ show e

  file <- S.readTextFile UTF8 (fp ["test", "Test.purs"])
  log "\n\nreadTextFile sync result:"
  log $ file

  catchException' (\err -> do
    log $ "Caught readTextFile error:\n" ++ show err
    return "") $ S.readTextFile UTF8 (fp ["test", "does not exist"])

  -- If an error is thrown, it's probably EEXIST, so ignore it. Should
  -- really check this instead.
  catchException' (const (return unit)) (S.mkdir "tmp")

  S.writeTextFile ASCII (fp ["tmp", "Test.js"]) "console.log('hello world')"
  S.rename (fp ["tmp", "Test.js"]) (fp ["tmp", "Test1.js"])

  S.truncate (fp ["tmp", "Test1.js"]) 1000

  stats <- S.stat (fp ["tmp", "Test1.js"])
  log "\n\nS.stat:"
  log "isFile:"
  log $ show $ isFile stats
  log "isDirectory:"
  log $ show $ isDirectory stats
  log "isBlockDevice:"
  log $ show $ isBlockDevice stats
  log "isCharacterDevice:"
  log $ show $ isCharacterDevice stats
  log "isFIFO:"
  log $ show $ isFIFO stats
  log "isSocket:"
  log $ show $ isSocket stats
  log "isSymbolicLink:"
  log $ show $ isSymbolicLink stats
  log "modifiedTime:"
  log $ show $ modifiedTime stats
  log "accessedTime:"
  log $ show $ accessedTime stats
  log "statusChangedTime:"
  log $ show $ statusChangedTime stats

  A.rename (fp ["tmp", "Test1.js"]) (fp ["tmp", "Test.js"]) $ \x -> do
    log "\n\nrename result:"
    either (log <<< show) (log <<< show) x

    A.truncate (fp ["tmp", "Test.js"]) 10 $ \x -> do
      log "\n\ntruncate result:"
      either (log <<< show) (log <<< show) x

  A.readFile (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nreadFile result:"
    either (log <<< show) (log <<< show) x

  A.readTextFile UTF8 (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nreadTextFile result:"
    either (log <<< show) log x

  A.stat (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nstat:"
    case x of
      Left err -> log $ "Error:" ++ show err
      Right x' -> do
        log "isFile:"
        log $ show $ isFile x'
        log "isDirectory:"
        log $ show $ isDirectory x'
        log "isBlockDevice:"
        log $ show $ isBlockDevice x'
        log "isCharacterDevice:"
        log $ show $ isCharacterDevice x'
        log "isFIFO:"
        log $ show $ isFIFO x'
        log "isSocket:"
        log $ show $ isSocket x'
        log "isSymbolicLink:"
        log $ show $ isSymbolicLink x'
        log "modifiedTime:"
        log $ show $ modifiedTime x'
        log "accessedTime:"
        log $ show $ accessedTime x'
        log "statusChangedTime:"
        log $ show $ statusChangedTime x'

  let fdFile = fp ["tmp", "FD.json"]
  fd0 <- S.fdOpen fdFile W (Just 420)
  buf0 <- Buffer.fromString "[ 42 ]" UTF8
  bytes0 <- S.fdAppend fd0 buf0
  S.fdFlush fd0
  S.fdClose fd0
  fd1 <- S.fdOpen fdFile R Nothing
  buf1 <- Buffer.create =<< Buffer.size buf0
  bytes1 <- S.fdNext fd1 buf1
  S.fdClose fd1

  log "statSync on a non-existing file should be catchable"
  r <- catchException'
        (const (pure true))
        (S.stat "this-does-not-exist" *> pure false)
  unless r $
    throwException (error "FS.Sync.stat should have thrown")

module Test where

import Prelude
import Data.Maybe
import Data.Either
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Console (log)
import Node.Encoding
import qualified Node.Buffer as Buffer
import qualified Node.Path as Path
import Unsafe.Coerce

import Node.FS
import Node.FS.Stats
import qualified Node.FS.Async as A
import qualified Node.FS.Sync as S

-- Cheat to allow `main` to type check. See also issue #5 in
-- purescript-exceptions.
catchException' ::
  forall a eff.
    (Error -> Eff (err :: EXCEPTION | eff) a)
    -> Eff (err :: EXCEPTION | eff) a
    -> Eff (err :: EXCEPTION | eff) a
catchException' = unsafeCoerce catchException

main = do
  let fp = Path.concat

  A.exists (fp ["test", "Test.purs"]) $ \e ->
    log $ "Test.purs exists? " ++ show e

  file <- S.readTextFile UTF8 (fp ["test", "Test.purs"])
  log "\n\nreadTextFile sync result:"
  log $ file

  catchException' (\err -> do
    log $ "Caught readTextFile error:\n" ++ show err
    return "") $ S.readTextFile UTF8 (fp ["test", "does not exist"])

  -- If an error is thrown, it's probably EEXIST, so ignore it. Should
  -- really check this instead.
  catchException' (const (return unit)) (S.mkdir "tmp")

  S.writeTextFile ASCII (fp ["tmp", "Test.js"]) "console.log('hello world')"
  S.rename (fp ["tmp", "Test.js"]) (fp ["tmp", "Test1.js"])

  S.truncate (fp ["tmp", "Test1.js"]) 1000

  stats <- S.stat (fp ["tmp", "Test1.js"])
  log "\n\nS.stat:"
  log "isFile:"
  log $ show $ isFile stats
  log "isDirectory:"
  log $ show $ isDirectory stats
  log "isBlockDevice:"
  log $ show $ isBlockDevice stats
  log "isCharacterDevice:"
  log $ show $ isCharacterDevice stats
  log "isFIFO:"
  log $ show $ isFIFO stats
  log "isSocket:"
  log $ show $ isSocket stats
  log "isSymbolicLink:"
  log $ show $ isSymbolicLink stats
  log "modifiedTime:"
  log $ show $ modifiedTime stats
  log "accessedTime:"
  log $ show $ accessedTime stats
  log "statusChangedTime:"
  log $ show $ statusChangedTime stats

  A.rename (fp ["tmp", "Test1.js"]) (fp ["tmp", "Test.js"]) $ \x -> do
    log "\n\nrename result:"
    either (log <<< show) (log <<< show) x

    A.truncate (fp ["tmp", "Test.js"]) 10 $ \x -> do
      log "\n\ntruncate result:"
      either (log <<< show) (log <<< show) x

  A.readFile (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nreadFile result:"
    either (log <<< show) (log <<< show) x

  A.readTextFile UTF8 (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nreadTextFile result:"
    either (log <<< show) log x

  A.stat (fp ["test", "Test.purs"]) $ \x -> do
    log "\n\nstat:"
    case x of
      Left err -> log $ "Error:" ++ show err
      Right x' -> do
        log "isFile:"
        log $ show $ isFile x'
        log "isDirectory:"
        log $ show $ isDirectory x'
        log "isBlockDevice:"
        log $ show $ isBlockDevice x'
        log "isCharacterDevice:"
        log $ show $ isCharacterDevice x'
        log "isFIFO:"
        log $ show $ isFIFO x'
        log "isSocket:"
        log $ show $ isSocket x'
        log "isSymbolicLink:"
        log $ show $ isSymbolicLink x'
        log "modifiedTime:"
        log $ show $ modifiedTime x'
        log "accessedTime:"
        log $ show $ accessedTime x'
        log "statusChangedTime:"
        log $ show $ statusChangedTime x'

  let fdFile = fp ["tmp", "FD.json"]
  fd0 <- S.fdOpen fdFile W (Just 420)
  buf0 <- Buffer.fromString "[ 42 ]" UTF8
  bytes0 <- S.fdAppend fd0 buf0
  S.fdFlush fd0
  S.fdClose fd0
  fd1 <- S.fdOpen fdFile R Nothing
  buf1 <- Buffer.create =<< Buffer.size buf0
  bytes1 <- S.fdNext fd1 buf1
  S.fdClose fd1


Fixed typos in comments and simplified types

module Hand (
    Suit(..),
    showSuit,
    Level,
    toLevel,
    Tricks,
    toTricks,
    HonoursType(..),
    Honours(..),
    Doubled(..),
    Hand,
    newHand,
    setDeclarer,
    setAllPass,
    setSuit,
    setLevel,
    setTricks,
    setHonours,
    setDoubled,
    renderHand,
    scoreHand
) where

import Prelude (class Eq, const, between, otherwise, show, pure, not, join,
    ($), (&&), (+), (*), (-), (>=), (==), (/=), (<>), (<$>), (<@>), (<*>))
import Data.Maybe (Maybe(..))
import Data.Maybe (maybe) as Maybe
import Data.Either (Either(..))
import Data.List (List(..))
import Data.String.CodeUnits (singleton) as String
import Data.String.Utils (padStart, padEnd) as String
import Data.Validation.Semigroup (V(..))
import Data.Validation.Semigroup (toEither) as V
import Score (ScoreEntry, Team, opposition, getTeam, TeamValue)

-- 5 Possible Suit Bids
data Suit = Clubs | Diamonds | Hearts | Spades | NoTrumps

-- Render a suit
showSuit :: Suit -> String
showSuit Clubs = "♣"
showSuit Diamonds = "♦"
showSuit Hearts = "♥"
showSuit Spades = "♠"
showSuit NoTrumps = "\\"

-- Classification of suits by point value
data SuitType = Minor | Major | NT

-- Get classification
suitType :: Suit -> SuitType
suitType Clubs = Minor
suitType Diamonds = Minor
suitType Hearts = Major
suitType Spades = Major
suitType NoTrumps = NT

-- Difference between first level and subsequent levels
bonusValue :: SuitType -> Int
bonusValue NT = 10
bonusValue _ = 0

-- Value of each level
suitValue :: SuitType -> Int
suitValue Minor = 20
suitValue _ = 30

-- Bidding level
newtype Level = Level Int

toLevel :: Int -> Maybe Level
toLevel x   | between 1 7 x     = Just $ Level x
            | otherwise         = Nothing

-- Tricks won
newtype Tricks = Tricks Int

toTricks :: Int -> Maybe Tricks
toTricks x  | between 0 13 x    = Just $ Tricks x
            | otherwise         = Nothing

-- Result of a hand
data Result = WonBy Int | LostBy Int

-- Get result of contract
result :: Level -> Maybe Tricks -> Result
result _ Nothing = WonBy 0 -- Default value if tricks not specified
result (Level x) (Just (Tricks y))
    | y >= x + 6    = WonBy $ y - x - 6
    | otherwise     = LostBy $ x + 6 - y

-- Render result of contract
renderResult :: Result -> String
renderResult (WonBy amount) = "+" <> show amount
renderResult (LostBy amount) = "-" <> show amount

-- Honours held
data HonoursType = Aces | Four | Five

-- Check validity of honours selection
validHonours :: HonoursType -> Suit -> Boolean
validHonours Aces NoTrumps = true
validHonours _ NoTrumps = false
validHonours Aces _ = false
validHonours _ _ = true

-- Points won by holder
honoursValue :: HonoursType -> Int
honoursValue Four = 100
honoursValue _ = 150

data Honours = None | Hons Team HonoursType

validHons :: Honours -> Suit -> Boolean
validHons (Hons _ honours) = validHonours honours
validHons _ = const true

-- Doubling
data Doubled = Undoubled | Doubled | Redoubled

doubleFactor :: Doubled -> Int
doubleFactor Undoubled = 1
doubleFactor Doubled = 2
doubleFactor Redoubled = 4

derive instance eqdoubled :: Eq Doubled

-- All data for one hand, possibly incomplete
type Hand = {
    allPass :: Boolean,
    declarer :: Maybe Char,
    team :: Maybe Team,
    suit :: Maybe Suit,
    level :: Maybe Level,
    tricks :: Maybe Tricks,
    honours :: Maybe Honours,
    doubled :: Doubled
}

-- Default hand
newHand :: Hand
newHand = {
    allPass : false,
    declarer : Nothing,
    team : Nothing,
    suit : Nothing,
    level : Nothing,
    tricks : Nothing,
    honours : Nothing,
    doubled : Undoubled
}

-- Set the declarer of a hand
setDeclarer :: Char -> Team -> Hand -> Hand
setDeclarer declarer team = _ {
    allPass = false,
    declarer = Just declarer,
    team = Just team
}

-- Everyone passed
setAllPass :: Hand -> Hand
setAllPass = _ {
    allPass = true,
    declarer = Nothing,
    team = Nothing
}

-- Set the suit bid
setSuit :: Suit -> Hand -> Hand
setSuit suit hand = case hand.honours of
    Just (Hons _ hons) | not $ validHonours hons suit ->
        hand { suit = Just suit, honours = Nothing }
    _ -> hand { suit = Just suit }

-- Set the level bid
setLevel :: Level -> Hand -> Hand
setLevel level = _ { level = Just level }

-- Set the number of tricks bid
setTricks :: Tricks -> Hand -> Hand
setTricks tricks = _ { tricks = Just tricks }

-- Set the honours bonus won
setHonours :: Honours -> Hand -> Hand
setHonours honours@(Hons _ hons) hand = case hand.suit of
    Just suit | not $ validHonours hons suit -> hand { honours = Nothing }
    _ -> hand { honours = Just honours }
setHonours honours hand = hand { honours = Just honours }

-- Set whether the contract was doubled
setDoubled :: Doubled -> Hand -> Hand
setDoubled doubled = _ { doubled = doubled }

-- Render the name of a contract
renderContract :: forall t. { declarer :: Maybe Char, level :: Maybe Level,
    suit :: Maybe Suit, doubled :: Doubled | t } -> String
renderContract contract = declarer <> level <> suit <> doubling where
    declarer = Maybe.maybe " " String.singleton contract.declarer
    level = case contract.level of
        Nothing -> " "
        Just (Level lev) -> show lev
    suit = Maybe.maybe " " showSuit contract.suit
    doubling = case contract.doubled of
        Undoubled -> ""
        Doubled -> "X"
        Redoubled -> "XX"

-- Render the result of a hand
renderHand :: Hand -> String
renderHand hand | hand.allPass = "AP"
                | otherwise =
    contract <> results <> honours where
        contract = String.padEnd 6 $ renderContract hand
        results = String.padStart 3 $ Maybe.maybe "" renderResult $
            result <$> hand.level <@> hand.tricks
        honours = case hand.honours of
            Just (Hons _ _) -> "h"
            _ -> " "

type Errors = Array String

-- Assign scores to a hand given all details of the hand
scoreHand' :: Char -> Team -> Suit -> Level -> Maybe Tricks -> Honours ->
    Doubled -> Either Errors (TeamValue Boolean -> List (ScoreEntry String))
scoreHand' declarer team suit level tricks hons doubled
    | not $ validHons hons suit = Left ["Invalid choice of Honours for this Suit"]
    | otherwise = Right $ \vuln -> let
        -- Name of contract, used for tags
        contract = renderContract {
            declarer : Just declarer,
            level : Just level,
            suit : Just suit,
            doubled
        }
        vulnerable = getTeam team vuln
        Level levelnum = level
        below = pure {
            team,
            below : true,
            -- Points below are simply suit value * amount * doubling, except notrumps adds 10 points
            amount : doubleFactor doubled * (levelnum * suitValue (suitType suit)
                + bonusValue (suitType suit)),
            source : "Won " <> contract
        }
        overBonus x
            | x == 0 = Nil -- No overtricks won, no points
            | doubled == Undoubled = pure {
                    team,
                    below : false,
                    -- Undoubled overtricks are simply suit value * amount
                    amount : x * suitValue (suitType suit),
                    source : contract <> " with " <> show x <> " overtricks"
                }
            | vulnerable = pure {
                    team,
                    below : false,
                    -- Vulnerable overtricks are 200 each doubled, 400 each redoubled
                    amount : 100 * doubleFactor doubled * x,
                    source : contract <> " with " <> show x <> " overtricks and vulnerable"
                }
            | otherwise = pure {
                    team,
                    below : false,
                    -- Not vulnerable overtricks are 100 each doubled, 200 each redoubled
                    amount : 50 * doubleFactor doubled * x,
                    source : contract <> " with " <> show x <> " overtricks"
                }
        insult -- Bonus of 50 points for winning a doubled contract, 100 for redoubled
            | doubled == Undoubled = Nil
            | otherwise = pure {
                    team,
                    below : false,
                    amount : doubleFactor doubled * 25,
                    source : contract <> " insult bonus"
                }
        slam
            | levelnum >= 6 && vulnerable = pure {
                    team,
                    below : false,
                    -- Vulnerable slams are 750 for baby slam and 1500 for grand slam
                    amount : 750 * (levelnum - 5),
                    source : contract <> " slam bonus and vulnerable"
                }
            | levelnum >= 6 = pure {
                    team,
                    below : false,
                    -- Not vulnerable slams are 500 for baby slam and 1000 for grand slam
                    amount : 500 * (levelnum - 5),
                    source : contract <> " slam bonus"
                }
            | otherwise = Nil -- Didn't bid 6 or 7, no slam
        honours = case hons of
            None -> Nil
            Hons honsteam honstype -> pure {
                    team : honsteam,
                    below : false,
                    amount : honoursValue honstype,
                    source : contract <> " honours"
                }
        -- calculate points for undertricks with tail call recursion
        underPoints 0 tot = tot -- base case, return running total
        underPoints x tot
            | doubled /= Undoubled && x >= 4 = underPoints (x-1) $
                -- 4th and later are worth 300 doubled, 600 redoubled
                tot + 150 * doubleFactor doubled
            | doubled /= Undoubled && x >= 2 && vulnerable = underPoints (x-1) $
                -- 2nd and 3rd are worth 300 doubled, 600 redoubled, when declarer is vulnerable
                tot + 150 * doubleFactor doubled
            | doubled /= Undoubled && x >= 2 = underPoints (x-1) $
                -- 2nd and 3rd are worth 200 doubled, 400 redoubled, when declarer is not vulnerable
                tot + 100 * doubleFactor doubled
            -- 1st is worth 200 doubled, 400 redoubled, and all undoubled are worth 100, when declarer is vulnerable
            | vulnerable = tot + 100 * doubleFactor doubled * x
            -- 1st is worth 100 doubled, 200 redoubled, and all undoubled are worth 50, when declarer is not vulnerable
            | otherwise = tot + 50 * doubleFactor doubled * x
        unders x = pure {
            team : opposition team,
            below : false,
            amount : underPoints x 0,
            source : "Lost " <> contract <> " with " <> show x <> " undertricks"
        }
    in case result level tricks of
        -- If contract won, give points for the contract, overtricks, insult bonus, slam bonus, and honours
        WonBy over -> below <> overBonus over <> insult <> slam <> honours
        -- If contract lost, give points for the undertricks and honours
        LostBy under -> unders under <> honours

-- Give an error message for an absent value
withError :: forall a b. Maybe a -> b -> V (Array b) a
withError Nothing e = V $ Left [e]
withError (Just x) _ = V $ Right x

-- Get a score generator for a hand, or errors if the hand cannot be scored
scoreHand :: Hand -> Either Errors (TeamValue Boolean -> List (ScoreEntry String))
scoreHand hand
    | hand.allPass = pure $ const Nil
    | otherwise = join $ V.toEither scores
    where
        scores = scoreHand'
            <$> (hand.declarer `withError` "Declarer was not chosen")
            <*> (hand.team `withError` "Declarer's team was not set")
            <*> (hand.suit `withError` "Bid suit was not chosen")
            <*> (hand.level `withError` "Bid level was not chosen")
            <@> hand.tricks -- Default is for contract to be won with no overtricks
            <*> (hand.honours `withError` "Honours has not been selected")
            <@> hand.doubled -- Default is undoubled

module Hand (
    Suit(..),
    showSuit,
    Level,
    toLevel,
    Tricks,
    toTricks,
    HonoursType(..),
    Honours(..),
    Doubled(..),
    Hand,
    newHand,
    setDeclarer,
    setAllPass,
    setSuit,
    setLevel,
    setTricks,
    setHonours,
    setDoubled,
    renderHand,
    scoreHand
) where

import Prelude (class Eq, const, between, otherwise, show, pure, not, join,
    ($), (&&), (+), (*), (-), (>=), (==), (/=), (<>), (<$>), (<@>), (<*>))
import Data.Maybe (Maybe(..))
import Data.Maybe (maybe) as Maybe
import Data.Either (Either(..))
import Data.List (List(..))
import Data.String.CodeUnits (singleton) as String
import Data.String.Utils (padStart, padEnd) as String
import Data.Validation.Semigroup (V(..))
import Data.Validation.Semigroup (toEither) as V
import Score (ScoreEntry, Team, opposition, getTeam, TeamValue)

-- 5 Possible Suit Bids
data Suit = Clubs | Diamonds | Hearts | Spades | NoTrumps

-- Render a suit
showSuit :: Suit -> String
showSuit Clubs = "♣"
showSuit Diamonds = "♦"
showSuit Hearts = "♥"
showSuit Spades = "♠"
showSuit NoTrumps = "\\"

-- Classification of suits by point value
data SuitType = Minor | Major | NT

-- Get classification
suitType :: Suit -> SuitType
suitType Clubs = Minor
suitType Diamonds = Minor
suitType Hearts = Major
suitType Spades = Major
suitType NoTrumps = NT

-- Difference between first level and subsequent levels
bonusValue :: SuitType -> Int
bonusValue NT = 10
bonusValue _ = 0

-- Value of each level
suitValue :: SuitType -> Int
suitValue Minor = 20
suitValue _ = 30

-- Bidding level
newtype Level = Level Int

toLevel :: Int -> Maybe Level
toLevel x   | between 1 7 x     = Just $ Level x
            | otherwise         = Nothing

-- Tricks won
newtype Tricks = Tricks Int

toTricks :: Int -> Maybe Tricks
toTricks x  | between 0 13 x    = Just $ Tricks x
            | otherwise         = Nothing

-- Result of a hand
data Result = WonBy Int | LostBy Int

-- Get result of contract
result :: Level -> Maybe Tricks -> Result
result _ Nothing = WonBy 0 -- Default value if tricks not specified
result (Level x) (Just (Tricks y))
    | y >= x + 6    = WonBy $ y - x - 6
    | otherwise     = LostBy $ x + 6 - y

-- Render result of contract
renderResult :: Result -> String
renderResult (WonBy amount) = "+" <> show amount
renderResult (LostBy amount) = "-" <> show amount

-- Honours held
data HonoursType = Aces | Four | Five

-- Check validity of honours selection
validHonours :: HonoursType -> Suit -> Boolean
validHonours Aces NoTrumps = true
validHonours _ NoTrumps = false
validHonours Aces _ = false
validHonours _ _ = true

-- Points won by holder
honoursValue :: HonoursType -> Int
honoursValue Four = 100
honoursValue _ = 150

data Honours = None | Hons Team HonoursType

validHons :: Honours -> Suit -> Boolean
validHons (Hons _ honours) = validHonours honours
validHons _ = const true

-- Doubling
data Doubled = Undoubled | Doubled | Redoubled

doubleFactor :: Doubled -> Int
doubleFactor Undoubled = 1
doubleFactor Doubled = 2
doubleFactor Redoubled = 4

derive instance eqdoubled :: Eq Doubled

-- All data for one hand, possibly incomplete
type Hand = {
    allPass :: Boolean,
    declarer :: Maybe Char,
    team :: Maybe Team,
    suit :: Maybe Suit,
    level :: Maybe Level,
    tricks :: Maybe Tricks,
    honours :: Maybe Honours,
    doubled :: Doubled
}

-- Default hand
newHand :: Hand
newHand = {
    allPass : false,
    declarer : Nothing,
    team : Nothing,
    suit : Nothing,
    level : Nothing,
    tricks : Nothing,
    honours : Nothing,
    doubled : Undoubled
}

-- Set the declarer of a hand
setDeclarer :: Char -> Team -> Hand -> Hand
setDeclarer declarer team = _ {
    allPass = false,
    declarer = Just declarer,
    team = Just team
}

-- Everyone passed
setAllPass :: Hand -> Hand
setAllPass = _ {
    allPass = true,
    declarer = Nothing,
    team = Nothing
}

-- Set the suit bid
setSuit :: Suit -> Hand -> Hand
setSuit suit hand = case hand.honours of
    Just (Hons _ hons) | not $ validHonours hons suit ->
        hand { suit = Just suit, honours = Nothing }
    _ -> hand { suit = Just suit }

-- Set the level bid
setLevel :: Level -> Hand -> Hand
setLevel level = _ { level = Just level }

-- Set the number of tricks bid
setTricks :: Tricks -> Hand -> Hand
setTricks tricks = _ { tricks = Just tricks }

-- Set the honours bonus won
setHonours :: Honours -> Hand -> Hand
setHonours honours@(Hons _ hons) hand = case hand.suit of
    Just suit | not $ validHonours hons suit -> hand { honours = Nothing }
    _ -> hand { honours = Just honours }
setHonours honours hand = hand { honours = Just honours }

-- Set whether the contract was doubled
setDoubled :: Doubled -> Hand -> Hand
setDoubled doubled = _ { doubled = doubled }

-- Render the name of a contract
renderContract :: forall t. { declarer :: Maybe Char, level :: Maybe Level,
    suit :: Maybe Suit, doubled :: Doubled | t } -> String
renderContract contract = declarer <> level <> suit <> doubling where
    declarer = Maybe.maybe " " String.singleton contract.declarer
    level = case contract.level of
        Nothing -> " "
        Just (Level lev) -> show lev
    suit = Maybe.maybe " " showSuit contract.suit
    doubling = case contract.doubled of
        Undoubled -> ""
        Doubled -> "X"
        Redoubled -> "XX"

-- Render the result of a hand
renderHand :: Hand -> String
renderHand hand | hand.allPass = "AP"
                | otherwise =
    contract <> results <> honours where
        contract = String.padEnd 6 $ renderContract hand
        results = String.padStart 3 $ Maybe.maybe "" renderResult $
            result <$> hand.level <@> hand.tricks
        honours = case hand.honours of
            Just (Hons _ _) -> "h"
            _ -> " "

type Errors = Array String

-- Assign scores to a hand given all details of the hand
scoreHand' :: Char -> Team -> Suit -> Level -> Maybe Tricks -> Honours ->
    Doubled -> V Errors (TeamValue Boolean -> List (ScoreEntry String))
scoreHand' declarer team suit level tricks hons doubled
    | not $ validHons hons suit = V $ Left ["Invalid choice of Honours for this Suit"]
    | otherwise = V $ Right $ \vuln -> let
        -- Name of contract, used for tags
        contract = renderContract {
            declarer : Just declarer,
            level : Just level,
            suit : Just suit,
            doubled
        }
        vulnerable = getTeam team vuln
        Level levelnum = level
        below = pure {
            team,
            below : true,
            -- Points below are simply suit value * amount * doubling, except notrumps adds 10 points
            amount : doubleFactor doubled * (levelnum * suitValue (suitType suit)
                + bonusValue (suitType suit)),
            source : "Won " <> contract
        }
        overBonus x
            | x == 0 = Nil -- No overtricks won, no points
            | doubled == Undoubled = pure {
                    team,
                    below : false,
                    -- Undoubled overtricks are simply suit value * amount
                    amount : x * suitValue (suitType suit),
                    source : contract <> " with " <> show x <> " overtricks"
                }
            | vulnerable = pure {
                    team,
                    below : false,
                    -- Vulnerable overtricks are 200 each doubled, 400 each redoubled
                    amount : 100 * doubleFactor doubled * x,
                    source : contract <> " with " <> show x <> " overtricks and vulnerable"
                }
            | otherwise = pure {
                    team,
                    below : false,
                    -- Not vulnerable overtricks are 100 each doubled, 200 each redoubled
                    amount : 50 * doubleFactor doubled * x,
                    source : contract <> " with " <> show x <> " overtricks"
                }
        insult -- Bonus of 50 points for winning a doubled contract, 100 for redoubled
            | doubled == Undoubled = Nil
            | otherwise = pure {
                    team,
                    below : false,
                    amount : doubleFactor doubled * 25,
                    source : contract <> " insult bonus"
                }
        slam
            | levelnum >= 6 && vulnerable = pure {
                    team,
                    below : false,
                    -- Vulnerable slams are 750 for baby slam and 1500 for grand slam
                    amount : 750 * (levelnum - 5),
                    source : contract <> " slam bonus and vulnerable"
                }
            | levelnum >= 6 = pure {
                    team,
                    below : false,
                    -- Not vulnerable slams are 500 for baby slam and 1000 for grand slam
                    amount : 500 * (levelnum - 5),
                    source : contract <> " slam bonus"
                }
            | otherwise = Nil -- Didn't bid 6 or 7, no slam
        honours = case hons of
            None -> Nil
            Hons honsteam honstype -> pure {
                    team : honsteam,
                    below : false,
                    amount : honoursValue honstype,
                    source : contract <> " honours"
                }
        -- calculate points for undertricks with tail call recursion
        underPoints 0 tot = tot -- base case, return running total
        underPoints x tot
            | doubled /= Undoubled && x >= 4 = underPoints (x-1) $
                -- 4th and later are worth 300 doubled, 600 undoubled
                tot + 150 * doubleFactor doubled
            | doubled /= Undoubled && x >= 2 && vulnerable = underPoints (x-1) $
                -- 2nd and 3rd are worth 300 doubled, 600 redoubled, when declarer is vulnerable
                tot + 150 * doubleFactor doubled
            | doubled /= Undoubled && x >= 2 = underPoints (x-1) $
                -- 2nd and 3rd are worth 200 doubled, 400 redoubled, when declarer is not vulnerable
                tot + 100 * doubleFactor doubled
            -- 1st is worth 200 doubled, 400 redoubled, and all undoubled are worth 100, when declarer is vulnerable
            | vulnerable = tot + 100 * doubleFactor doubled * x
            -- 1st is worth 100 doubled, 200 redoubled, and all undoubled are worth 50, when declarer is not vulnerable
            | otherwise = tot + 50 * doubleFactor doubled * x
        unders x = pure {
            team : opposition team,
            below : false,
            amount : underPoints x 0,
            source : "Lost " <> contract <> " with " <> show x <> " undertricks"
        }
    in case result level tricks of
        -- If contract won, give points for the contract, overtricks, insult bonus, slam bonus, and honours
        WonBy over -> below <> overBonus over <> insult <> slam <> honours
        -- If contract lost, give points for the undertricks and honours
        LostBy under -> unders under <> honours

-- Give an error message for an absent value
withError :: forall a b. Maybe a -> b -> V (Array b) a
withError Nothing e = V $ Left [e]
withError (Just x) _ = V $ Right x

-- Get a score generator for a hand, or errors if the hand cannot be score
scoreHand :: Hand -> Either Errors (TeamValue Boolean -> List (ScoreEntry String))
scoreHand hand
    | hand.allPass = pure $ const Nil
    | otherwise = join $ V.toEither $ V.toEither <$> scores
    where
        scores = scoreHand'
            <$> (hand.declarer `withError` "Declarer was not chosen")
            <*> (hand.team `withError` "Declarer's team was not set")
            <*> (hand.suit `withError` "Bid suit was not chosen")
            <*> (hand.level `withError` "Bid level was not chosen")
            <@> hand.tricks -- Default is for contract to be won with no overtricks
            <*> (hand.honours `withError` "Honours has not been selected")
            <@> hand.doubled -- Default is undoubled


Upgrade Effect and Type from ! and *

Upgrade Effect and Type from ! and *

module Web.Firebase.Types (
     DataSnapshot
   , Firebase
   , FirebaseEff
   , FirebaseErr
   , Key)
where

-- in process of moving the to string conversion function here, as it belongs with the typeclass
import Control.Monad.Eff (kind Effect)
import Prelude (class Show, class Eq, (==))

foreign import data FirebaseEff :: Effect

foreign import data Firebase :: Type
foreign import data FirebaseErr :: Type

foreign import firebaseErrToString :: FirebaseErr -> String

instance showFirebaseErr :: Show FirebaseErr where
  show err = firebaseErrToString err

instance eqFirebaseErr :: Eq FirebaseErr where
  eq e1 e2 = (firebaseErrToString e1) == (firebaseErrToString e2)

{-
  https://www.firebase.com/docs/web/guide/user-auth.html#section-handling-errors:
  All errors are Error objects containing at least code and message attributes. In some cases, additional information will be provided via the details attribute. For example:
  {
	    code: "TRANSPORT_UNAVAILABLE",
       message: "There are no login transports available for the requested method.",
         details: "More details about the specific error here."
 }
-}

--https://www.firebase.com/docs/web/api/datasnapshot/
foreign import data DataSnapshot :: Type

type Key = String

module Web.Firebase.Types (
     DataSnapshot
   , Firebase
   , FirebaseEff
   , FirebaseErr
   , Key)
where

-- in process of moving the to string conversion function here, as it belongs with the typeclass
import Prelude (class Show, class Eq, (==))

foreign import data FirebaseEff :: !

foreign import data Firebase :: *
foreign import data FirebaseErr :: *

foreign import firebaseErrToString :: FirebaseErr -> String

instance showFirebaseErr :: Show FirebaseErr where
  show err = firebaseErrToString err

instance eqFirebaseErr :: Eq FirebaseErr where
  eq e1 e2 = (firebaseErrToString e1) == (firebaseErrToString e2)

{-
  https://www.firebase.com/docs/web/guide/user-auth.html#section-handling-errors:
  All errors are Error objects containing at least code and message attributes. In some cases, additional information will be provided via the details attribute. For example:
  {
	    code: "TRANSPORT_UNAVAILABLE",
       message: "There are no login transports available for the requested method.",
         details: "More details about the specific error here."
 }
-}

--https://www.firebase.com/docs/web/api/datasnapshot/
foreign import data DataSnapshot :: *

type Key = String


removed commented code-line

removed commented code-line

module Test.Signal
  ( expect
  , expectFn
  , tick
  ) where

import Prelude
import Effect.Aff (makeAff, nonCanceler)
import Effect.Exception (error)
import Effect.Ref (Ref, write, read, new)
import Data.Either (Either(..))
import Data.Function.Uncurried (Fn4, runFn4)
import Data.List (List(..), fromFoldable, toUnfoldable)
import Signal (Signal, constant, (~>), runSignal)
import Test.Unit (Test, timeout)

type Tail a = Ref (Array a)

expectFn :: forall a. Eq a => Show a => Signal a -> Array a -> Test
expectFn sig vals = makeAff \resolve -> do
  remaining <- new vals
  let getNext val = do
        nextValArray <- read remaining
        let nextVals = fromFoldable nextValArray
        case nextVals of
          Cons x xs -> do
            if x /= val then resolve $ Left $ error $ "expected " <> show x <> " but got " <> show val
              else case xs of
                Nil -> resolve $ Right unit
                _ ->
                  write (toUnfoldable xs) remaining
          Nil -> resolve $ Left $ error "unexpected emptiness"
  runSignal $ sig ~> getNext
  pure nonCanceler

expect :: forall a. Eq a => Show a => Int -> Signal a -> Array a -> Test
expect time sig vals = timeout time $ expectFn sig vals

foreign import tickP :: forall a c. Fn4 (c -> Signal c) Int Int (Array a) (Signal a)

tick :: forall a. Int -> Int -> Array a -> Signal a
tick = runFn4 tickP constant

module Test.Signal
  ( expect
  , expectFn
  , tick
  ) where

import Prelude
import Effect.Aff (makeAff, nonCanceler)
import Effect.Exception (error)
import Effect.Ref (Ref, write, read, new)
import Data.Either (Either(..))
import Data.Function.Uncurried (Fn4, runFn4)
import Data.List (List(..), fromFoldable, toUnfoldable)
import Signal (Signal, constant, (~>), runSignal)
import Test.Unit (Test, timeout)

type Tail a = Ref (Array a)

expectFn :: forall a. Eq a => Show a => Signal a -> Array a -> Test
expectFn sig vals = makeAff \resolve -> do
  remaining <- new vals
  let getNext val = do
        nextValArray <- read remaining
        let nextVals = fromFoldable nextValArray
        case nextVals of
          Cons x xs -> do
            if x /= val then resolve $ Left $ error $ "expected " <> show x <> " but got " <> show val
              else case xs of
                Nil -> resolve $ Right unit
                _ ->
                  -- write remaining (toUnfoldable xs)
                  write (toUnfoldable xs) remaining
          Nil -> resolve $ Left $ error "unexpected emptiness"
  runSignal $ sig ~> getNext
  pure nonCanceler

expect :: forall a. Eq a => Show a => Int -> Signal a -> Array a -> Test
expect time sig vals = timeout time $ expectFn sig vals

foreign import tickP :: forall a c. Fn4 (c -> Signal c) Int Int (Array a) (Signal a)

tick :: forall a. Int -> Int -> Array a -> Signal a
tick = runFn4 tickP constant


Easier to understand

Easier to understand

module Main where

import Data.Maybe
import Data.String
import Data.Either

import Data.Coords
import Data.GameItem
import Data.GameState
import Data.GameEnvironment

import Control.Monad.Eff
import Control.Monad.RWS
import Control.Monad.RWS.Class

import Game

import Debug.Trace

import qualified Node.ReadLine as RL

import qualified Node.Yargs as Y
import qualified Node.Yargs.Setup as Y
import qualified Node.Yargs.Applicative as Y

runGame :: GameEnvironment -> Eff (console :: RL.Console, trace :: Trace) Unit
runGame env = do
  interface <- RL.createInterface RL.process.stdin RL.process.stdout RL.noCompletion
  RL.setPrompt "> " 2 interface

  let
    lineHandler :: GameState -> String -> Eff (console :: RL.Console, trace :: Trace) Unit
    lineHandler currentState input = do
      let result = runRWS (game (split " " input)) env currentState
      foreachE result.log trace
      RL.setLineHandler (lineHandler result.state) interface
      RL.prompt interface
      return unit

  RL.setLineHandler (lineHandler initialGameState) interface
  RL.prompt interface

  return unit

main = Y.runY (Y.usage "$0 -p <player name>") $ runGame <$> env
  where
  env :: Y.Y GameEnvironment
  env = gameEnvironment <$> Y.yarg "p" ["player"]
                                   (Just "Player name")
                                   (Right "The player name is required")
                                   false
                        <*> Y.flag "d" ["debug"]
                                   (Just "Use debug mode")

module Main where

import Data.Maybe
import Data.String
import Data.Either

import Data.Coords
import Data.GameItem
import Data.GameState
import Data.GameEnvironment

import Control.Monad.Eff
import Control.Monad.RWS
import Control.Monad.RWS.Class

import Game

import Debug.Trace

import qualified Node.ReadLine as RL

import qualified Node.Yargs as Y
import qualified Node.Yargs.Setup as Y
import qualified Node.Yargs.Applicative as Y

runGame :: GameEnvironment -> Eff (console :: RL.Console, trace :: Trace) Unit
runGame env = do
  interface <- RL.createInterface RL.process.stdin RL.process.stdout RL.noCompletion
  RL.setPrompt "> " 2 interface

  let
    lineHandler :: GameState -> String -> Eff (console :: RL.Console, trace :: Trace) Unit
    lineHandler currentState input = do
      let result = runRWS (game (split " " input)) env currentState
      foreachE result.log trace
      RL.setLineHandler (lineHandler result.state) interface
      RL.prompt interface
      return unit

  RL.setLineHandler (lineHandler initialGameState) interface
  RL.prompt interface

  return unit

main =
  let env = gameEnvironment <$> Y.yarg "p" ["player"]
                                       (Just "Player name")
                                       (Right "The player name is required")
                                       false
                            <*> Y.flag "d" ["debug"]
                                       (Just "Use debug mode")
  in Y.runY (Y.usage "$0 -p <player name>") $ runGame <$> env


Show placeholder for the empty list, fixes #31

module Main (App(..), main) where

import Prelude
import Color (rgb, graytone)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
import DOM (DOM)
import DOM.HTML.Event.EventTypes (change, click, keydown)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Types (windowToEventTarget, htmlElementToEventTarget, htmlElementToElement)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent, parentElement)
import DOM.Node.Types (Element(), elementToNode, elementToEventTarget)
import Data.Array as A
import Data.Enum (enumFromTo)
import Data.Either (fromRight)
import Data.Foldable (foldl, traverse_)
import Data.Int (toNumber)
import Data.List (List(..), fromFoldable, filter, snoc, dropWhile, tail, head, (:), last, mapMaybe, reverse, length)
import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust)
import Data.Monoid (class Monoid, mempty)
import Data.Nullable (toMaybe)
import Data.StrMap as SM
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable (traverse)
import Partial.Unsafe (unsafePartial)
import Graphics.Drawing as D
import Graphics.Canvas (CANVAS, getCanvasElementById, getContext2D, clearRect, getCanvasWidth, getCanvasHeight)
import Graphics.Isometric (Scene, Color, scale, renderScene, prism, filled, cube)

import Analytics (analyticsLevelChanged)
import DOMHelper (addEventListener', withElementById, getElementById', getDocument, unsafeGetAttribute, children', getSelectedValue, setInnerHTML, ctrlKey, keyCode, unsafeEventToKeyboardEvent, unsafeElementToHTMLElement, setStyleAttribute, classRemove, classAdd)
import Levels (firstLevel, levelTitle, getLevel, getChapter, allLevelIds, getTransformer, getTransformerRecord)
import Sortable (installSortable)
import Storage (STORAGE, saveGameState, loadGameState)
import Transformer (allSteps)
import Types (GameState, LevelId, TransformerRecord, Chapter, TransformerId, Wall, Stack, Cube(..))

-- | Type synonyms for different combinations of effects
type EffDOM    = forall eff. Eff (dom :: DOM | eff) Unit
type App       = forall eff. Eff (dom :: DOM, console :: CONSOLE, canvas :: CANVAS, storage :: STORAGE | eff) Unit

-- | RGB codes for the abstract colors
cubeColor :: Cube -> Color
cubeColor Cyan   = rgb   0 160 176
cubeColor Brown  = rgb 106  74  60
cubeColor Red    = rgb 204  51  63
cubeColor Orange = rgb 235 104  65
cubeColor Yellow = rgb 237 201  81

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Like `foldMap` on `List`, but the function also takes an index parameter
foldMapIndexed :: forall a m. (Monoid m) => (Int -> a -> m) -> List a -> m
foldMapIndexed f xs = go 0 xs
    where go _ Nil         = mempty
          go i (Cons x xs) = f i x <> go (i + 1) xs

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

renderCube :: Int -> Int -> Int -> Cube -> Scene
renderCube x y z c = filled (cubeColor c) $ cube point 0.9
  where point = { x: toNumber (-x)
                , y: spacing * toNumber y
                , z: toNumber z }

-- | Render a single stack of cubes
renderStack :: Int -> Int -> Int -> Stack -> Scene
renderStack len y x stack = foldMapIndexed (renderCube (len - x) y) stack

-- | Render a wall (multiple stacks)
renderWall :: Int -> Wall -> Scene
renderWall y Nil =
    -- Render a gray placeholder for the empty wall
    filled gray $ prism { x: -8.0, y: spacing * toNumber y, z: 0.0 } 8.0 0.9 0.1
      where gray = graytone 0.4
renderWall y wall = foldMapIndexed (renderStack len y) (reverse wall)
  where len = length wall

-- | Render a series of walls
renderWalls :: List Wall -> Scene
renderWalls walls = foldMapIndexed renderWall walls

-- | Render the target shape
renderTarget :: Wall -> Scene
renderTarget target = renderWall 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> App
render setupUI gs = do
    doc <- getDocument
    canvas <- unsafeFromJust <$> getCanvasElementById "canvas"
    ctx <- getContext2D canvas

    w <- getCanvasWidth canvas
    h <- getCanvasHeight canvas

    let level   = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids    = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        ulAvailable <- unsafeFromJust <$> getElementById' "available" doc
        ulProgram   <- unsafeFromJust <$> getElementById' "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused       = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active =       foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addEventListener' click (clickLi (htmlElementToElement li)) (htmlElementToEventTarget li)
        children' ulAvailable >>= traverse_ installClickHandler
        children' ulProgram   >>= traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    let lightPos = { x: -2.0, y: 1.0, z: 3.0 }
    clearRect ctx { x: 0.0, y: 0.0, w, h }

    let renderCanvas x y s scene = D.render ctx $ D.translate x y $
            renderScene lightPos (scale s scene)
    renderCanvas    2.0 284.0 49.0 (renderWalls steps)
    renderCanvas 1280.0 380.0 35.0 (renderTarget level.target)

    -- DOM 'rendering'
    let solved = maybe false (_ == (level.target)) (last steps)
        visibility = if solved then "visible" else "hidden"
        cssAction = if solved then classAdd "flash" else classRemove "flash"

    withElementById "message" doc (setStyleAttribute "visibility" visibility <<< unsafeElementToHTMLElement)
    withElementById "solved" doc cssAction

    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- Debug output:
    let toArray = A.fromFoldable :: forall a. List a -> Array a
        toArrays = toArray <<< map toArray
    log $ "Program: " <> show (toArray tids)
    log $ "Target: " <> show (toArrays level.target)
    log "Steps:"
    traverse_ (logShow <<< toArrays) steps
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll regexString replacement = replace pattern replacement
    where
      flags = parseFlags "g"
      pattern = unsafePartial $ fromRight (regex regexString flags)

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" <> c <> "}"
              replacement c = "<div class=\"cube " <> c <> "\">
"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" <> id <> "`"
          replacement tr = "" <> tr.name <> ""

-- | Clear all functions for the current level
resetLevel :: App
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | Go to the previous level
prevLevel :: App
prevLevel = modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = prev gs.currentLevel }
          prev cur = fromMaybe cur $ before cur allLevelIds
          before _ Nil                   = Nothing
          before _ (Cons _ Nil)          = Nothing
          before x (Cons b (Cons x' xs)) = if x == x'
                                           then Just b
                                           else before x (x':xs)

-- | Go to the next level
nextLevel :: App
nextLevel = do
    mgs <- loadGameState
    let gs' = fromMaybe initialGS mgs
    analyticsLevelChanged (next gs'.currentLevel)

    modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = next gs.currentLevel }
          next cur = fromMaybe cur $ head =<< (tail $ dropWhile (_ /= cur) allLevelIds)

-- | General key press handler
keyPress :: Event -> App
keyPress event = void do
    doc <- getDocument
    let kev = unsafeEventToKeyboardEvent event
        code = keyCode kev
        ctrlPressed = ctrlKey kev

    when (not ctrlPressed) $
        case code of
             -- 'r': reset lists
             82 ->  resetLevel
             -- '<-', 'p': previous level
             37 -> prevLevel
             80 -> prevLevel
             -- '->', 'n': next level
             39 -> nextLevel
             78 -> nextLevel
             _ -> pure unit

-- | Click handler for the
 elements (transformers)
clickLi :: Element -> Event -> App
clickLi liEl event = do
    newId <- unsafeGetAttribute "id" liEl
    ul <- unsafeFromJust <$> toMaybe <$> parentElement (elementToNode liEl)
    ulId <- unsafeGetAttribute "id" ul
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (_ /= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: Element -> String -> TransformerRecord -> EffDOM
appendTransformerElement ul id t = void do
    doc <- getDocument
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild (elementToNode li) (elementToNode ul)

-- | Add an option-element corresponding to the given Level
appendLevelElement :: Element -> LevelId -> LevelId -> EffDOM
appendLevelElement select currentId lid = void do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- getDocument
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) (elementToNode option)
    appendChild (elementToNode option) (elementToNode select)

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: firstLevel, levelState: SM.empty }

-- | Load, modify and store the game state. Render the new state
modifyGameStateAndRender :: Boolean
                         -> (GameState -> GameState)
                         -> forall eff. Eff (dom :: DOM, console :: CONSOLE, canvas :: CANVAS, storage :: STORAGE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: Element -> Event -> App
levelChangeHandler selectLevel _ = do
    levelId <- getSelectedValue selectLevel

    analyticsLevelChanged levelId

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler :: App
reprogramHandler = do
    doc <- getDocument

    -- Retrieve current 'program'
    ulAvailable <- unsafeFromJust <$> getElementById' "program" doc
    lis <- children' ulAvailable
    let getId = unsafeGetAttribute "id" <<< htmlElementToElement
    program <- fromFoldable <$> traverse getId lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

-- | Unsafe version of `fromJust`
unsafeFromJust :: forall a. Maybe a -> a
unsafeFromJust = unsafePartial fromJust

main :: App
main = do
    doc <- getDocument

    -- install sortable
    ulAvailable <- unsafeFromJust <$> getElementById' "available" doc
    ulProgram   <- unsafeFromJust <$> getElementById' "program" doc
    installSortable ulAvailable (pure unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    win <- windowToEventTarget <$> window
    addEventListener' keydown keyPress win

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addEventListener' change (levelChangeHandler selectLevel) (elementToEventTarget selectLevel)

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addEventListener' click (const resetLevel) (elementToEventTarget button)

    withElementById "nextlevel" doc $ \button ->
        addEventListener' click (const nextLevel) (elementToEventTarget button)

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (App(..), main) where

import Prelude
import Color (rgb, graytone)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
import DOM (DOM)
import DOM.HTML.Event.EventTypes (change, click, keydown)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Types (windowToEventTarget, htmlElementToEventTarget, htmlElementToElement)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent, parentElement)
import DOM.Node.Types (Element(), elementToNode, elementToEventTarget)
import Data.Array as A
import Data.Enum (enumFromTo)
import Data.Either (fromRight)
import Data.Foldable (foldl, traverse_)
import Data.Int (toNumber)
import Data.List (List(..), fromFoldable, filter, snoc, dropWhile, tail, head, (:), last, mapMaybe, reverse, length)
import Data.Maybe (Maybe(..), fromMaybe, maybe, fromJust)
import Data.Monoid (class Monoid, mempty)
import Data.Nullable (toMaybe)
import Data.StrMap as SM
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable (traverse)
import Partial.Unsafe (unsafePartial)
import Graphics.Drawing as D
import Graphics.Canvas (CANVAS, getCanvasElementById, getContext2D, clearRect, getCanvasWidth, getCanvasHeight)
import Graphics.Isometric (Scene, Color, scale, renderScene, prism, filled, cube)

import Analytics (analyticsLevelChanged)
import DOMHelper (addEventListener', withElementById, getElementById', getDocument, unsafeGetAttribute, children', getSelectedValue, setInnerHTML, ctrlKey, keyCode, unsafeEventToKeyboardEvent, unsafeElementToHTMLElement, setStyleAttribute, classRemove, classAdd)
import Levels (firstLevel, levelTitle, getLevel, getChapter, allLevelIds, getTransformer, getTransformerRecord)
import Sortable (installSortable)
import Storage (STORAGE, saveGameState, loadGameState)
import Transformer (allSteps)
import Types (GameState, LevelId, TransformerRecord, Chapter, TransformerId, Wall, Stack, Cube(..))

-- | Type synonyms for different combinations of effects
type EffDOM    = forall eff. Eff (dom :: DOM | eff) Unit
type App       = forall eff. Eff (dom :: DOM, console :: CONSOLE, canvas :: CANVAS, storage :: STORAGE | eff) Unit

-- | RGB codes for the abstract colors
cubeColor :: Cube -> Color
cubeColor Cyan   = rgb   0 160 176
cubeColor Brown  = rgb 106  74  60
cubeColor Red    = rgb 204  51  63
cubeColor Orange = rgb 235 104  65
cubeColor Yellow = rgb 237 201  81

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Like `foldMap` on `List`, but the function also takes an index parameter
foldMapIndexed :: forall a m. (Monoid m) => (Int -> a -> m) -> List a -> m
foldMapIndexed f xs = go 0 xs
    where go _ Nil         = mempty
          go i (Cons x xs) = f i x <> go (i + 1) xs

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

renderCube :: Int -> Int -> Int -> Cube -> Scene
renderCube x y z c = filled (cubeColor c) $ cube point 0.9
  where point = { x: toNumber (-x)
                , y: spacing * toNumber y
                , z: toNumber z }

-- | Render a single stack of cubes
renderStack :: Int -> Int -> Int -> Stack -> Scene
renderStack len y x stack = foldMapIndexed (renderCube (len - x) y) stack

-- | Render a wall (multiple stacks)
renderWall :: Int -> Wall -> Scene
renderWall y Nil =
    -- Render a gray placeholder for the empty wall
    filled gray $ prism { x: 1.0, y: -spacing * toNumber y, z: 0.0 } 5.0 0.9 0.1
      where gray = graytone 0.4
renderWall y wall = foldMapIndexed (renderStack len y) (reverse wall)
  where len = length wall

-- | Render a series of walls
renderWalls :: List Wall -> Scene
renderWalls walls = foldMapIndexed renderWall walls

-- | Render the target shape
renderTarget :: Wall -> Scene
renderTarget target = renderWall 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> App
render setupUI gs = do
    doc <- getDocument
    canvas <- unsafeFromJust <$> getCanvasElementById "canvas"
    ctx <- getContext2D canvas

    w <- getCanvasWidth canvas
    h <- getCanvasHeight canvas

    let level   = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids    = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        ulAvailable <- unsafeFromJust <$> getElementById' "available" doc
        ulProgram   <- unsafeFromJust <$> getElementById' "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused       = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active =       foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addEventListener' click (clickLi (htmlElementToElement li)) (htmlElementToEventTarget li)
        children' ulAvailable >>= traverse_ installClickHandler
        children' ulProgram   >>= traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    let lightPos = { x: -2.0, y: 1.0, z: 3.0 }
    clearRect ctx { x: 0.0, y: 0.0, w, h }

    let renderCanvas x y s scene = D.render ctx $ D.translate x y $
            renderScene lightPos (scale s scene)
    renderCanvas    2.0 284.0 49.0 (renderWalls steps)
    renderCanvas 1280.0 380.0 35.0 (renderTarget level.target)

    -- DOM 'rendering'
    let solved = maybe false (_ == (level.target)) (last steps)
        visibility = if solved then "visible" else "hidden"
        cssAction = if solved then classAdd "flash" else classRemove "flash"

    withElementById "message" doc (setStyleAttribute "visibility" visibility <<< unsafeElementToHTMLElement)
    withElementById "solved" doc cssAction

    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- Debug output:
    let toArray = A.fromFoldable :: forall a. List a -> Array a
        toArrays = toArray <<< map toArray
    log $ "Program: " <> show (toArray tids)
    log $ "Target: " <> show (toArrays level.target)
    log "Steps:"
    traverse_ (logShow <<< toArrays) steps
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll regexString replacement = replace pattern replacement
    where
      flags = parseFlags "g"
      pattern = unsafePartial $ fromRight (regex regexString flags)

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" <> c <> "}"
              replacement c = "<div class=\"cube " <> c <> "\">
"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" <> id <> "`"
          replacement tr = "" <> tr.name <> ""

-- | Clear all functions for the current level
resetLevel :: App
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | Go to the previous level
prevLevel :: App
prevLevel = modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = prev gs.currentLevel }
          prev cur = fromMaybe cur $ before cur allLevelIds
          before _ Nil                   = Nothing
          before _ (Cons _ Nil)          = Nothing
          before x (Cons b (Cons x' xs)) = if x == x'
                                           then Just b
                                           else before x (x':xs)

-- | Go to the next level
nextLevel :: App
nextLevel = do
    mgs <- loadGameState
    let gs' = fromMaybe initialGS mgs
    analyticsLevelChanged (next gs'.currentLevel)

    modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = next gs.currentLevel }
          next cur = fromMaybe cur $ head =<< (tail $ dropWhile (_ /= cur) allLevelIds)

-- | General key press handler
keyPress :: Event -> App
keyPress event = void do
    doc <- getDocument
    let kev = unsafeEventToKeyboardEvent event
        code = keyCode kev
        ctrlPressed = ctrlKey kev

    when (not ctrlPressed) $
        case code of
             -- 'r': reset lists
             82 ->  resetLevel
             -- '<-', 'p': previous level
             37 -> prevLevel
             80 -> prevLevel
             -- '->', 'n': next level
             39 -> nextLevel
             78 -> nextLevel
             _ -> pure unit

-- | Click handler for the
 elements (transformers)
clickLi :: Element -> Event -> App
clickLi liEl event = do
    newId <- unsafeGetAttribute "id" liEl
    ul <- unsafeFromJust <$> toMaybe <$> parentElement (elementToNode liEl)
    ulId <- unsafeGetAttribute "id" ul
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (_ /= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: Element -> String -> TransformerRecord -> EffDOM
appendTransformerElement ul id t = void do
    doc <- getDocument
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild (elementToNode li) (elementToNode ul)

-- | Add an option-element corresponding to the given Level
appendLevelElement :: Element -> LevelId -> LevelId -> EffDOM
appendLevelElement select currentId lid = void do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- getDocument
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) (elementToNode option)
    appendChild (elementToNode option) (elementToNode select)

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: firstLevel, levelState: SM.empty }

-- | Load, modify and store the game state. Render the new state
modifyGameStateAndRender :: Boolean
                         -> (GameState -> GameState)
                         -> forall eff. Eff (dom :: DOM, console :: CONSOLE, canvas :: CANVAS, storage :: STORAGE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: Element -> Event -> App
levelChangeHandler selectLevel _ = do
    levelId <- getSelectedValue selectLevel

    analyticsLevelChanged levelId

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler :: App
reprogramHandler = do
    doc <- getDocument

    -- Retrieve current 'program'
    ulAvailable <- unsafeFromJust <$> getElementById' "program" doc
    lis <- children' ulAvailable
    let getId = unsafeGetAttribute "id" <<< htmlElementToElement
    program <- fromFoldable <$> traverse getId lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

-- | Unsafe version of `fromJust`
unsafeFromJust :: forall a. Maybe a -> a
unsafeFromJust = unsafePartial fromJust

main :: App
main = do
    doc <- getDocument

    -- install sortable
    ulAvailable <- unsafeFromJust <$> getElementById' "available" doc
    ulProgram   <- unsafeFromJust <$> getElementById' "program" doc
    installSortable ulAvailable (pure unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    win <- windowToEventTarget <$> window
    addEventListener' keydown keyPress win

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addEventListener' change (levelChangeHandler selectLevel) (elementToEventTarget selectLevel)

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addEventListener' click (const resetLevel) (elementToEventTarget button)

    withElementById "nextlevel" doc $ \button ->
        addEventListener' click (const nextLevel) (elementToEventTarget button)

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs