Drop mention of `unfoldr` that refers to nothing

-- | This module provides a type class for _unfoldable functors_, i.e.
-- | functors which support an `unfoldr` operation.
-- |
-- | This allows us to unify various operations on arrays, lists,
-- | sequences, etc.

module Data.Unfoldable
  ( class Unfoldable, unfoldr
  , replicate
  , replicateA
  , none
  , singleton
  , range
  , fromMaybe
  ) where

import Prelude

import Data.Maybe (Maybe(..), isNothing, fromJust)
import Data.Traversable (class Traversable, sequence)
import Data.Tuple (Tuple(..), fst, snd)

import Partial.Unsafe (unsafePartial)

-- | This class identifies data structures which can be _unfolded_.
-- |
-- | The generating function `f` in `unfoldr f` in understood as follows:
-- |
-- | - If `f b` is `Nothing`, then `unfoldr f b` should be empty.
-- | - If `f b` is `Just (Tuple a b1)`, then `unfoldr f b` should consist of `a`
-- |   appended to the result of `unfoldr f b1`.
class Unfoldable t where
  unfoldr :: forall a b. (b -> Maybe (Tuple a b)) -> b -> t a

instance unfoldableArray :: Unfoldable Array where
  unfoldr = unfoldrArrayImpl isNothing (unsafePartial fromJust) fst snd

foreign import unfoldrArrayImpl
  :: forall a b
   . (forall x. Maybe x -> Boolean)
  -> (forall x. Maybe x -> x)
  -> (forall x y. Tuple x y -> x)
  -> (forall x y. Tuple x y -> y)
  -> (b -> Maybe (Tuple a b))
  -> b
  -> Array a

-- | Replicate a value some natural number of times.
-- | For example:
-- |
-- | ~~~ purescript
-- | replicate 2 "foo" == ["foo", "foo"] :: Array String
-- | ~~~
replicate :: forall f a. Unfoldable f => Int -> a -> f a
replicate n v = unfoldr step n
  where
    step :: Int -> Maybe (Tuple a Int)
    step i =
      if i <= 0 then Nothing
      else Just (Tuple v (i - 1))

-- | Perform an Applicative action `n` times, and accumulate all the results.
replicateA
  :: forall m f a
   . Applicative m
  => Unfoldable f
  => Traversable f
  => Int
  -> m a
  -> m (f a)
replicateA n m = sequence (replicate n m)

-- | The container with no elements - unfolded with zero iterations.
-- | For example:
-- |
-- | ~~~ purescript
-- | none == [] :: forall a. Array a
-- | ~~~
none :: forall f a. Unfoldable f => f a
none = unfoldr (const Nothing) unit

-- | Contain a single value.
-- | For example:
-- |
-- | ~~~ purescript
-- | singleton "foo" == ["foo"] :: Array String
-- | ~~~
singleton :: forall f a. Unfoldable f => a -> f a
singleton = replicate 1

-- | Create an Unfoldable containing a range of values, with both endpoints.
range :: forall f. Unfoldable f => Int -> Int -> f Int
range start end =
  unfoldr (\i -> if i <= end then Just (Tuple i $ i + 1) else Nothing) start

-- | Convert a Maybe to any Unfoldable like lists and arrays.
fromMaybe :: forall f a. Unfoldable f => Maybe a -> f a
fromMaybe = unfoldr (\b -> flip Tuple Nothing <$> b)

-- | This module provides a type class for _unfoldable functors_, i.e.
-- | functors which support an `unfoldr` operation.
-- |
-- | This allows us to unify various operations on arrays, lists,
-- | sequences, etc.

module Data.Unfoldable
  ( class Unfoldable, unfoldr
  , replicate
  , replicateA
  , none
  , singleton
  , range
  , fromMaybe
  ) where

import Prelude

import Data.Maybe (Maybe(..), isNothing, fromJust)
import Data.Traversable (class Traversable, sequence)
import Data.Tuple (Tuple(..), fst, snd)

import Partial.Unsafe (unsafePartial)

-- | This class identifies data structures which can be _unfolded_,
-- | generalizing `unfoldr` on arrays.
-- |
-- | The generating function `f` in `unfoldr f` in understood as follows:
-- |
-- | - If `f b` is `Nothing`, then `unfoldr f b` should be empty.
-- | - If `f b` is `Just (Tuple a b1)`, then `unfoldr f b` should consist of `a`
-- |   appended to the result of `unfoldr f b1`.
class Unfoldable t where
  unfoldr :: forall a b. (b -> Maybe (Tuple a b)) -> b -> t a

instance unfoldableArray :: Unfoldable Array where
  unfoldr = unfoldrArrayImpl isNothing (unsafePartial fromJust) fst snd

foreign import unfoldrArrayImpl
  :: forall a b
   . (forall x. Maybe x -> Boolean)
  -> (forall x. Maybe x -> x)
  -> (forall x y. Tuple x y -> x)
  -> (forall x y. Tuple x y -> y)
  -> (b -> Maybe (Tuple a b))
  -> b
  -> Array a

-- | Replicate a value some natural number of times.
-- | For example:
-- |
-- | ~~~ purescript
-- | replicate 2 "foo" == ["foo", "foo"] :: Array String
-- | ~~~
replicate :: forall f a. Unfoldable f => Int -> a -> f a
replicate n v = unfoldr step n
  where
    step :: Int -> Maybe (Tuple a Int)
    step i =
      if i <= 0 then Nothing
      else Just (Tuple v (i - 1))

-- | Perform an Applicative action `n` times, and accumulate all the results.
replicateA
  :: forall m f a
   . Applicative m
  => Unfoldable f
  => Traversable f
  => Int
  -> m a
  -> m (f a)
replicateA n m = sequence (replicate n m)

-- | The container with no elements - unfolded with zero iterations.
-- | For example:
-- |
-- | ~~~ purescript
-- | none == [] :: forall a. Array a
-- | ~~~
none :: forall f a. Unfoldable f => f a
none = unfoldr (const Nothing) unit

-- | Contain a single value.
-- | For example:
-- |
-- | ~~~ purescript
-- | singleton "foo" == ["foo"] :: Array String
-- | ~~~
singleton :: forall f a. Unfoldable f => a -> f a
singleton = replicate 1

-- | Create an Unfoldable containing a range of values, with both endpoints.
range :: forall f. Unfoldable f => Int -> Int -> f Int
range start end =
  unfoldr (\i -> if i <= end then Just (Tuple i $ i + 1) else Nothing) start

-- | Convert a Maybe to any Unfoldable like lists and arrays.
fromMaybe :: forall f a. Unfoldable f => Maybe a -> f a
fromMaybe = unfoldr (\b -> flip Tuple Nothing <$> b)


Fix unexhaustive pattern

Fix unexhaustive pattern

module Language.Docopt.Value (
    Value (..)
  , isSameValueType
  , isBoolValue
  , isArrayValue
  , prettyPrintValue
  ) where

import Prelude
import Data.Generic

data Value
  = StringValue String
  | BoolValue   Boolean
  | ArrayValue  (Array Value)
  | IntValue    Int
  | FloatValue  Number

derive instance genericValue :: Generic Value

instance showValue :: Show Value where
  show (StringValue s) = "StringValue " ++ s
  show (BoolValue   b) = "BoolValue "   ++ show b
  show (ArrayValue xs) = "ArrayValue "  ++ show (show <$> xs)
  show (IntValue    x) = "IntValue "    ++ show x
  show (FloatValue  x) = "FloatValue "  ++ show x

instance eqValue :: Eq Value where
  eq (StringValue s) (StringValue s') = s  == s'
  eq (BoolValue   b) (BoolValue   b') = b  == b'
  eq (ArrayValue xs) (ArrayValue xs') = xs == xs'
  eq (FloatValue  x) (FloatValue  x') = x  == x'
  eq (IntValue    x) (IntValue    x') = x  == x'
  eq _               _                = false

isSameValueType :: Value -> Value -> Boolean
isSameValueType (StringValue _) (StringValue _) = true
isSameValueType (BoolValue   _) (BoolValue   _) = true
isSameValueType (ArrayValue  _) (ArrayValue  _) = true
isSameValueType (IntValue    _) (IntValue    _) = true
isSameValueType (FloatValue  _) (FloatValue  _) = true
isSameValueType _               _               = false

isBoolValue :: Value -> Boolean
isBoolValue (BoolValue _) = true
isBoolValue _             = false

isArrayValue :: Value -> Boolean
isArrayValue (ArrayValue _) = true
isArrayValue _              = false

isIntValue :: Value -> Boolean
isIntValue (IntValue _) = true
isIntValue _            = false

isFloatValue :: Value -> Boolean
isFloatValue (FloatValue _) = true
isFloatValue _              = false

prettyPrintValue :: Value -> String
prettyPrintValue (StringValue s) = s
prettyPrintValue (BoolValue   b) = show b
prettyPrintValue (ArrayValue xs) = show $ prettyPrintValue <$> xs
prettyPrintValue (IntValue    i) = show i


Use 'dim' code in place of 'gray'

Use 'dim' code in place of 'gray'

Gray is invisible on the Solarized theme. Dim achieves a similar effect.
Dim is not supported on Windows but will be ignored afaik, rather than making the text invisible.
See https://github.com/eslint/eslint/pull/4885 for explanation and pictures.

module Test.Spec.Color where

import Prelude ((<<<))

data Color
 = Pass
 | Fail
 | Pending
 | Suite
 | ErrorTitle
 | ErrorMessage
 | ErrorStack
 | Checkmark
 | Fast
 | Medium
 | Slow
 | Green
 | Light

code :: Color -> Int
code Pass         = 2
code Fail         = 31
code Pending      = 36
code Suite        = 0
code ErrorTitle   = 0
code ErrorMessage = 31
code ErrorStack   = 2
code Checkmark    = 32
code Fast         = 2
code Medium       = 33
code Slow         = 31
code Green        = 32
code Light        = 2

colored :: Color -> String -> String
colored = _colored <<< code

foreign import _colored :: Int -> String -> String

module Test.Spec.Color where

import Prelude ((<<<))

data Color
 = Pass
 | Fail
 | Pending
 | Suite
 | ErrorTitle
 | ErrorMessage
 | ErrorStack
 | Checkmark
 | Fast
 | Medium
 | Slow
 | Green
 | Light

code :: Color -> Int
code Pass         = 90
code Fail         = 31
code Pending      = 36
code Suite        = 0
code ErrorTitle   = 0
code ErrorMessage = 31
code ErrorStack   = 90
code Checkmark    = 32
code Fast         = 90
code Medium       = 33
code Slow         = 31
code Green        = 32
code Light        = 90

colored :: Color -> String -> String
colored = _colored <<< code

foreign import _colored :: Int -> String -> String


Fix link to repo @GitHub

Fix link to repo @GitHub

module Explorer.View.Footer (footerView) where

import Prelude
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.String (take)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (common, cApi, footer, fooLinks, fooResources, fooFollow, fooIohkSupportP, fooDocumentation, fooGithub, fooLinkedin, fooTwitter, fooDaedalusWallet, fooWhyCardano, fooCardanoRoadmap, fooCardanoADAFaucet, fooCardanoSLDocumentation) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Types.Actions (Action)
import Explorer.Types.State (State)
import Explorer.Util.Config (commitHash, version)
import Explorer.View.Common (langView)

import Text.Smolder.HTML (div, nav, a, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((!))

import Pux.DOM.HTML (HTML) as P

footerView :: State -> P.HTML Action
footerView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-footer" $ do
        S.div ! S.className "explorer-footer__top" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.nav ! S.className "nav__container" $ do
                    navRowView $ resourcesNavRow lang'
                    navRowView $ followUsNavRow lang'
                    navRowView $ linksNavRow lang'
        S.div ! S.className "explorer-footer__bottom" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "content content__left" $ do
                    S.div ! S.className "logo__container" $ do
                        S.a ! S.className "logo__cardano-name bg-logo-cardano-name"
                            ! S.href "https://iohk.io/projects/cardano/"
                            $ S.text ""
                    S.span  ! S.className "split"
                            $ S.text ""
                    S.a ! S.className "support"
                        ! S.href "//iohk.io/projects/cardano/"
                        $ S.text (translate (I18nL.footer <<< I18nL.fooIohkSupportP) lang')
                    S.div ! S.className "logo__container"
                          $ S.a ! S.className "logo__iohk-name bg-iohk-logo"
                                ! S.href "https://iohk.io/"
                                $ S.text ""
                S.div ! S.className "content content__right"
                      $ langView state
            S.div ! S.className "explorer-footer__container explorer-footer__meta" $ do
                S.span  ! S.className "version"
                        $ S.text ("v. " <> version)
                S.a ! S.className "commit"
                    ! S.href ("https://github.com/input-output-hk/cardano-sl/commit/" <> commitHash)
                    $ S.text $ "( " <> (take 7 $ commitHash) <> " )"

-- nav

type NavItem =
    { label :: String
    , link :: String
    }

type NaviItemHeader = String

type NavRow =
    { header :: String
    , items :: Array NavItem
    }

resourcesNavRow :: Language -> NavRow
resourcesNavRow lang =
    { header: translate (I18nL.footer <<< I18nL.fooResources) lang
    , items: navItemsRow0 lang }

navItemsRow0 :: Language -> Array NavItem
navItemsRow0 lang =
    [ { label: translate (I18nL.common <<< I18nL.cApi) lang
      , link: "https://cardanodocs.com/technical/explorer/api/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooDocumentation) lang
      , link: "https://cardanodocs.com/cardano/explorer/"
      }
    -- TODO (ks) Add when we have the links
    -- , { label: "Support"
    --   , link: "/"
    --   }
    -- , { label: "Status"
    --   , link: "/"
    --   }
    -- , { label: "Charts"
    --   , link: "/"
    --   }
    ]

followUsNavRow :: Language -> NavRow
followUsNavRow lang =
    { header: translate (I18nL.footer <<< I18nL.fooFollow) lang
    , items: navItemsRow1 lang
    }

navItemsRow1 :: Language -> Array NavItem
navItemsRow1 lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooGithub) lang
      , link: "https://github.com/input-output-hk/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooLinkedin) lang
      , link: "https://www.linkedin.com/company-beta/6385405/?pathWildcard=6385405"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooTwitter) lang
      , link: "https://twitter.com/InputOutputHK"
      }
    ]

linksNavRow :: Language -> NavRow
linksNavRow  lang =
    { header: translate (I18nL.footer <<< I18nL.fooLinks) lang
    , items: navItemsRow2 lang
    }

navItemsRow2 :: Language -> Array NavItem
navItemsRow2 lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooDaedalusWallet) lang
      , link: "https://daedaluswallet.io/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooWhyCardano) lang
      , link: "https://whycardano.com/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoRoadmap) lang
      , link: "https://cardanoroadmap.com/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoADAFaucet) lang
      , link: "https://tada.iohk.io/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoSLDocumentation) lang
      , link: "https://cardanodocs.com/introduction/"
      }
    ]

navRowView :: NavRow -> P.HTML Action
navRowView row =
    S.div ! S.className "nav-item__container" $ do
        S.p ! S.className "nav-item__header"
            $ S.text row.header
        S.div $ for_ row.items navRowItemView

navRowItemView :: NavItem -> P.HTML Action
navRowItemView item =
    S.a ! S.className "nav-item__item"
        ! S.href item.link
        $ S.text item.label

module Explorer.View.Footer (footerView) where

import Prelude
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.String (take)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (common, cApi, footer, fooLinks, fooResources, fooFollow, fooIohkSupportP, fooDocumentation, fooGithub, fooLinkedin, fooTwitter, fooDaedalusWallet, fooWhyCardano, fooCardanoRoadmap, fooCardanoADAFaucet, fooCardanoSLDocumentation) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Types.Actions (Action)
import Explorer.Types.State (State)
import Explorer.Util.Config (commitHash, version)
import Explorer.View.Common (langView)

import Text.Smolder.HTML (div, nav, a, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((!))

import Pux.DOM.HTML (HTML) as P

footerView :: State -> P.HTML Action
footerView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-footer" $ do
        S.div ! S.className "explorer-footer__top" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.nav ! S.className "nav__container" $ do
                    navRowView $ resourcesNavRow lang'
                    navRowView $ followUsNavRow lang'
                    navRowView $ linksNavRow lang'
        S.div ! S.className "explorer-footer__bottom" $ do
            S.div ! S.className "explorer-footer__container" $ do
                S.div ! S.className "content content__left" $ do
                    S.div ! S.className "logo__container" $ do
                        S.a ! S.className "logo__cardano-name bg-logo-cardano-name"
                            ! S.href "https://iohk.io/projects/cardano/"
                            $ S.text ""
                    S.span  ! S.className "split"
                            $ S.text ""
                    S.a ! S.className "support"
                        ! S.href "//iohk.io/projects/cardano/"
                        $ S.text (translate (I18nL.footer <<< I18nL.fooIohkSupportP) lang')
                    S.div ! S.className "logo__container"
                          $ S.a ! S.className "logo__iohk-name bg-iohk-logo"
                                ! S.href "https://iohk.io/"
                                $ S.text ""
                S.div ! S.className "content content__right"
                      $ langView state
            S.div ! S.className "explorer-footer__container explorer-footer__meta" $ do
                S.span  ! S.className "version"
                        $ S.text ("v. " <> version)
                S.a ! S.className "commit"
                    ! S.href ("https://github.com/input-output-hk/cardano-sl-explorer/commit/" <> commitHash)
                    $ S.text $ "( " <> (take 7 $ commitHash) <> " )"

-- nav

type NavItem =
    { label :: String
    , link :: String
    }

type NaviItemHeader = String

type NavRow =
    { header :: String
    , items :: Array NavItem
    }

resourcesNavRow :: Language -> NavRow
resourcesNavRow lang =
    { header: translate (I18nL.footer <<< I18nL.fooResources) lang
    , items: navItemsRow0 lang }

navItemsRow0 :: Language -> Array NavItem
navItemsRow0 lang =
    [ { label: translate (I18nL.common <<< I18nL.cApi) lang
      , link: "https://cardanodocs.com/technical/explorer/api/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooDocumentation) lang
      , link: "https://cardanodocs.com/cardano/explorer/"
      }
    -- TODO (ks) Add when we have the links
    -- , { label: "Support"
    --   , link: "/"
    --   }
    -- , { label: "Status"
    --   , link: "/"
    --   }
    -- , { label: "Charts"
    --   , link: "/"
    --   }
    ]

followUsNavRow :: Language -> NavRow
followUsNavRow lang =
    { header: translate (I18nL.footer <<< I18nL.fooFollow) lang
    , items: navItemsRow1 lang
    }

navItemsRow1 :: Language -> Array NavItem
navItemsRow1 lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooGithub) lang
      , link: "https://github.com/input-output-hk/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooLinkedin) lang
      , link: "https://www.linkedin.com/company-beta/6385405/?pathWildcard=6385405"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooTwitter) lang
      , link: "https://twitter.com/InputOutputHK"
      }
    ]

linksNavRow :: Language -> NavRow
linksNavRow  lang =
    { header: translate (I18nL.footer <<< I18nL.fooLinks) lang
    , items: navItemsRow2 lang
    }

navItemsRow2 :: Language -> Array NavItem
navItemsRow2 lang =
    [ { label: translate (I18nL.footer <<< I18nL.fooDaedalusWallet) lang
      , link: "https://daedaluswallet.io/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooWhyCardano) lang
      , link: "https://whycardano.com/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoRoadmap) lang
      , link: "https://cardanoroadmap.com/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoADAFaucet) lang
      , link: "https://tada.iohk.io/"
      }
    , { label: translate (I18nL.footer <<< I18nL.fooCardanoSLDocumentation) lang
      , link: "https://cardanodocs.com/introduction/"
      }
    ]

navRowView :: NavRow -> P.HTML Action
navRowView row =
    S.div ! S.className "nav-item__container" $ do
        S.p ! S.className "nav-item__header"
            $ S.text row.header
        S.div $ for_ row.items navRowItemView

navRowItemView :: NavItem -> P.HTML Action
navRowItemView item =
    S.a ! S.className "nav-item__item"
        ! S.href item.link
        $ S.text item.label


More time for performance tests for travis

module Test.PerfTests (perfTests) 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 Test.Helpers(NOW, now)

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

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

    log "\n# Performance tests"
    log "* 10K points"
    test10K
    -- zipWith takes around 3080 ms to complete. With DateTime index 200ms longer
    -- log "* 30k points"
    -- test30K
    log "* 60K points"
    test60K
    log "* 1M points"
    test1M
    log "* 10M points"
    test1M

test10K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test10K = do
    csv <- readTextFile UTF8 "testdata/test10k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    t1 <- now
    let s3 = TS.zipWith (+) s1 s2
    t2 <- now
    log $ "zipWith " <> show (TS.length s3) <> " points in " <> show (t2-t1) <> " milliseconds."
    assert $ t1-t2 < 5e3

test30K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test30K = do
    csv <- readTextFile UTF8 "testdata/test30k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    t1 <- now
    let s3 = TS.zipWith (+) s1 s2
    t2 <- now
    log $ "zipWith " <> show (TS.length s3) <> " points in " <> show (t2-t1) <> " milliseconds."
    assert $ t1-t2 < 1e4

test60K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test60K = do
    t1 <- now
    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 = A.filter ((==) false) $ A.zipWith (==) s1.values s2.values
    t2 <- now
    log $ "(filter <<< zip <<< fromCsv) " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 2e3

test1M :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test1M = do
    let s1 = TS.fromValues $ A.replicate 1000000 2.72
    t1 <- now
    let s3 = map (_ * 3.0) s1.values
    t2 <- now
    log $ "map " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 1e3

test10M :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test10M = do
    let s1 = TS.fromValues $ A.replicate 10000000 3.14
    t1 <- now
    let s3 = map (_ * 3.0) s1.values
    t2 <- now
    log $ "map " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 1e4

module Test.PerfTests (perfTests) 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 Test.Helpers(NOW, now)

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

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

    log "\n# Performance tests"
    log "* 10K points"
    test10K
    -- zipWith takes around 3080 ms to complete. With DateTime index 200ms longer
    -- log "* 30k points"
    -- test30K
    log "* 60K points"
    test60K
    log "* 1M points"
    test1M
    log "* 10M points"
    test1M

test10K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test10K = do
    csv <- readTextFile UTF8 "testdata/test10k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    t1 <- now
    let s3 = TS.zipWith (+) s1 s2
    t2 <- now
    log $ "zipWith " <> show (TS.length s3) <> " points in " <> show (t2-t1) <> " milliseconds."
    assert $ t1-t2 < 1e4

test30K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test30K = do
    csv <- readTextFile UTF8 "testdata/test30k.csv"
    let xs = IO.fromCsv csv
    let s1 = fromMaybe TS.empty $ A.index xs 0
    let s2 = fromMaybe TS.empty $ A.index xs 1
    t1 <- now
    let s3 = TS.zipWith (+) s1 s2
    t2 <- now
    log $ "zipWith " <> show (TS.length s3) <> " points in " <> show (t2-t1) <> " milliseconds."
    assert $ t1-t2 < 1e4

test60K :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test60K = do
    t1 <- now
    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 = A.filter ((==) false) $ A.zipWith (==) s1.values s2.values
    t2 <- now
    log $ "(filter <<< zip <<< fromCsv) " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 1e3

test1M :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test1M = do
    let s1 = TS.fromValues $ A.replicate 1000000 2.72
    t1 <- now
    let s3 = map (_ * 3.0) s1.values
    t2 <- now
    log $ "map " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 1e3

test10M :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS, now :: NOW  | eff) Unit
test10M = do
    let s1 = TS.fromValues $ A.replicate 10000000 3.14
    t1 <- now
    let s3 = map (_ * 3.0) s1.values
    t2 <- now
    log $ "map " <> show (t2-t1) <> " milliseconds."
    assert $ t2-t1 < 1e4


Remove old, commented-out testbed code

Remove old, commented-out testbed code

module Test.Spec.CompatSpec (compatSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff, later)
import Control.Alt ((<|>))
import Data.StrMap as StrMap
import Data.Bifunctor (lmap)
import Data.Pretty (pretty)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (intercalate, for_)
import Text.Wrap (dedent)
import Data.Maybe (Maybe(..), fromMaybe, fromJust, maybe)
import Data.Traversable (for)
import Data.List (List(..), many, toUnfoldable, concat)
import Test.Spec (Spec(), describe, it)
import Test.Spec (Spec()) as Test
import Data.String as String
import Test.Support (vliftEff)
import Partial.Unsafe (unsafePartial)
import Control.Apply ((*>), (<*))
import Node.FS (FS)

import Neodoc as Neodoc
import Neodoc (NeodocOptions(..))
import Neodoc.Value
import Neodoc.Env (Env)
import Neodoc.Env as Env
import Neodoc.Error.Class (capture) as Error
import Neodoc.Spec as Neodoc
import Neodoc.Spec (Spec(..))
import Neodoc.Spec.Parser as Spec
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Scanner as Scanner
import Neodoc.Solve as Solver
import Neodoc.Solve.Error (SolveError(..))
import Neodoc.Solve.ExpandOptions (expandOptions, ExpandedOptionsLayout(..)
, ExpandedOptionsLayoutArg(..))
import Neodoc.Data.SolvedLayout (SolvedLayout(..))
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.ArgParser as ArgParser
import Neodoc.ArgParser (ArgParseResult(..))
import Neodoc.Evaluate as Evaluate

import Test.Support.CompatParser

type CompatEff e = (fs :: FS, err :: EXCEPTION | e)

compatSpec :: ∀ e. List Test -> Test.Spec (CompatEff e) Unit
compatSpec tests =
  describe "Docopt compatibility" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc <> "\n") do
        for_ kases \(Kase { options: (NeodocOptions opts), out }) -> do
          let argv = unsafePartial $ fromJust opts.argv
              env  = unsafePartial $ fromJust opts.env
              flagsDesc = renderFlags { optionsFirst: opts.optionsFirst
                                      , smartOptions: opts.smartOptions
                                      , requireFlags: opts.requireFlags
                                      , laxPlacement: opts.laxPlacement
                                      , repeatableOptions: opts.repeatableOptions
                                      }
          describe (intercalate " " (
            (toUnfoldable $ StrMap.toList env <#> \t ->
                fst t <> "=\"" <> snd t <> "\"")
              <> argv
            )
            <> (if String.length flagsDesc > 0 then " # flags: " <> flagsDesc else "")
            ) do
            it ("\n" <> pretty out) do

              -- XXX: Manually break the execution context in order to avoid to
              --      avoid stack overflows by executing a large amount of Aff
              --      actions that run purely synchronous. Ideally, we would run
              --      the `Aff` action using it's `MonadRec` instance.
              -- Refer: https://github.com/owickstrom/purescript-spec/issues/24

              later (pure unit)

              let env = fromMaybe StrMap.empty opts.env
                  result = Neodoc.runPure (dedent doc) (NeodocOptions opts) Nothing

              vliftEff $ case result of
                Left e ->
                  either
                    (\es ->
                      if es == "user-error" || es == "spec-error"
                        then pure unit
                        else if (pretty e {- XXX: Check against `ArgParserError`? -}) == es
                          then pure unit
                          else throwException $ error $
                            "Unexpected exception message: \"" <> pretty e <> "\""
                    )
                    (const $ throwException $ error $ pretty e)
                    out
                Right (Neodoc.Output output) -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          <> pretty (StrMap.toList output)
                    )
                    (\expected ->
                      let actual = StrMap.toList output
                       in if (StrMap.fromFoldable expected /= output)
                        then throwException $ error $
                          "Unexpected output:\n"
                            <> pretty actual
                        else pure unit)
                    out
                Right x -> throwException $ error $
                              "Unexpected output:\n"
                                <> pretty x

module Test.Spec.CompatSpec (compatSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff, later)
import Control.Alt ((<|>))
import Data.StrMap as StrMap
import Data.Bifunctor (lmap)
import Data.Pretty (pretty)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (intercalate, for_)
import Text.Wrap (dedent)
import Data.Maybe (Maybe(..), fromMaybe, fromJust, maybe)
import Data.Traversable (for)
import Data.List (List(..), many, toUnfoldable, concat)
import Test.Spec (Spec(), describe, it)
import Test.Spec (Spec()) as Test
import Data.String as String
import Test.Support (vliftEff)
import Partial.Unsafe (unsafePartial)
import Control.Apply ((*>), (<*))
import Node.FS (FS)

import Neodoc as Neodoc
import Neodoc (NeodocOptions(..))
import Neodoc.Value
import Neodoc.Env (Env)
import Neodoc.Env as Env
import Neodoc.Error.Class (capture) as Error
import Neodoc.Spec as Neodoc
import Neodoc.Spec (Spec(..))
import Neodoc.Spec.Parser as Spec
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Scanner as Scanner
import Neodoc.Solve as Solver
import Neodoc.Solve.Error (SolveError(..))
import Neodoc.Solve.ExpandOptions (expandOptions, ExpandedOptionsLayout(..)
, ExpandedOptionsLayoutArg(..))
import Neodoc.Data.SolvedLayout (SolvedLayout(..))
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.ArgParser as ArgParser
import Neodoc.ArgParser (ArgParseResult(..))
import Neodoc.Evaluate as Evaluate

import Test.Support.CompatParser

type CompatEff e = (fs :: FS, err :: EXCEPTION | e)

compatSpec :: ∀ e. List Test -> Test.Spec (CompatEff e) Unit
compatSpec tests =
  describe "Docopt compatibility" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc <> "\n") do
        for_ kases \(Kase { options: (NeodocOptions opts), out }) -> do
          let argv = unsafePartial $ fromJust opts.argv
              env  = unsafePartial $ fromJust opts.env
              flagsDesc = renderFlags { optionsFirst: opts.optionsFirst
                                      , smartOptions: opts.smartOptions
                                      , requireFlags: opts.requireFlags
                                      , laxPlacement: opts.laxPlacement
                                      , repeatableOptions: opts.repeatableOptions
                                      }
          describe (intercalate " " (
            (toUnfoldable $ StrMap.toList env <#> \t ->
                fst t <> "=\"" <> snd t <> "\"")
              <> argv
            )
            <> (if String.length flagsDesc > 0 then " # flags: " <> flagsDesc else "")
            ) do
            it ("\n" <> pretty out) do

              -- XXX: Manually break the execution context in order to avoid to
              --      avoid stack overflows by executing a large amount of Aff
              --      actions that run purely synchronous. Ideally, we would run
              --      the `Aff` action using it's `MonadRec` instance.
              -- Refer: https://github.com/owickstrom/purescript-spec/issues/24

              later (pure unit)

              let env = fromMaybe StrMap.empty opts.env
                  result = Neodoc.runPure (dedent doc) (NeodocOptions opts) Nothing

              --       -- scan the input text
              --       { usage, options, originalUsage } <- Error.capture do
              --         Scanner.scan $ dedent doc
              --
              --       -- lex/parse the usage section
              --       { program, layouts } <- do
              --         toks <- Error.capture $ Lexer.lexUsage usage
              --         Error.capture $ Spec.parseUsage toks
              --
              --       -- lex/parse the description section(s)
              --       descriptions <- concat <$> for options \description -> do
              --         toks <- Error.capture $ Lexer.lexDescs description
              --         Error.capture $ Spec.parseDescription toks
              --
              --       -- solve the input spec
              --       spec' <- Error.capture do
              --         Solver.solve
              --           { smartOptions: opts.smartOptions }
              --           (Spec { program
              --                 , layouts
              --                 , descriptions
              --                 , helpText: doc
              --                 , shortHelp: originalUsage
              --                 })
              --
              --       -- run the arg parser
              --       ArgParseResult mBranch vs <- Error.capture do
              --         ArgParser.run spec' opts env argv
              --
              --       -- evaluate the results
              --       pure $ Evaluate.reduce env descriptions mBranch vs

              vliftEff $ case result of
                Left e ->
                  either
                    (\es ->
                      if es == "user-error" || es == "spec-error"
                        then pure unit
                        else if (pretty e {- XXX: Check against `ArgParserError`? -}) == es
                          then pure unit
                          else throwException $ error $
                            "Unexpected exception message: \"" <> pretty e <> "\""
                    )
                    (const $ throwException $ error $ pretty e)
                    out
                Right (Neodoc.Output output) -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          <> pretty (StrMap.toList output)
                    )
                    (\expected ->
                      let actual = StrMap.toList output
                       in if (StrMap.fromFoldable expected /= output)
                        then throwException $ error $
                          "Unexpected output:\n"
                            <> pretty actual
                        else pure unit)
                    out
                Right x -> throwException $ error $
                              "Unexpected output:\n"
                                <> pretty x


Halogen support for min/max utilized over manual props

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Setups.Transform.Place.Component where

import SlamData.Prelude
import Control.Monad.Eff.Random (randomInt)
import Data.Array as Array
import Data.Foldable as F
import Data.Lens as Lens
import Data.Profunctor (dimap)
import Halogen as H
import Halogen.Component.Profunctor (ProComponent(..))
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Numeric as N
import Utils (stringToInt, chunksOf)

data Query a
  = Init a
  | ChangePlace Int a

type State =
  { digits ∷ Array Int
  , place ∷ Int
  }

type DSL = H.ComponentDSL State Query (Maybe N.Place) Slam
type HTML = H.ComponentHTML Query

component ∷ (Int → Int → Int) → ProComponent HH.HTML Query Slam (Maybe N.Place) (Maybe N.Place)
component operation =
  ProComponent $ H.lifecycleComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
  initialState ∷ Maybe (N.Place) → State
  initialState = { digits: [], place: _ } ∘ case _ of
    Just (N.Place n) → clamp (-10) 10 n
    Nothing → 0

  render ∷ State → HTML
  render st =
    HH.div
      [ HP.classes [ HH.ClassName "sd-place-value-picker" ] ]
      [ HH.label_ [ HH.text "Place" ]
      , HH.p
          [ HP.classes [ HH.ClassName "place-value" ] ]
          (renderNumber st.digits st.place)
      , HH.p_
          [ HH.input
              [ HP.type_ HP.InputRange
              , HP.min (-10.0)
              , HP.max 10.0
              , HP.value (show (-st.place))
              , HE.onValueInput (map (H.action ∘ ChangePlace ∘ negate) ∘ stringToInt)
              ]
          ]
      ]

  bold ∷ String → HTML
  bold a = HH.b_ [ HH.text a ]

  renderNumber ∷ Array Int → Int → Array HTML
  renderNumber ds n =
    let
      pivotIx = 10 + n
      digitIx = pivotIx + 1
      fn      = operation $ fromMaybe 0 $ Array.index ds pivotIx
      ds'     = flip Array.mapWithIndex ds case _, _ of
                  ix, val | ix ≡ digitIx → bold $ show (fn val)
                          | ix < digitIx → HH.text "0"
                          | otherwise    → HH.text $ show val
      nths    = Array.reverse $ Array.take 11 ds'
      ns      = Array.reverse $ F.intercalate [ HH.text "," ] $ chunksOf 3 (Array.drop 11 ds')
    in
      ns <> [ HH.text "." ] <> nths

  eval ∷ Query ~> DSL
  eval = case _ of
    Init next → do
      digits ← genDigits
      H.modify _ { digits = digits }
      pure next
    ChangePlace n next → do
      H.modify _ { place = n }
      H.raise (Just (N.Place n))
      pure next

genDigits ∷ DSL (Array Int)
genDigits =
  -- We only do 1 - 8 to simplify the operation
  H.liftEff $ sequence (Array.replicate 23 (randomInt 1 8))

transformFloor ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformFloor =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Floor))
    (map (T.Numeric ∘ N.Floor))
    (component (const id))

transformRound ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformRound =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Round))
    (map (T.Numeric ∘ N.Round))
    (component \n → if n < 5 then id else (_ + 1))

transformCeil ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformCeil =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Ceil))
    (map (T.Numeric ∘ N.Ceil))
    (component (const (_ + 1)))

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Setups.Transform.Place.Component where

import SlamData.Prelude
import Control.Monad.Eff.Random (randomInt)
import Data.Array as Array
import Data.Foldable as F
import Data.Lens as Lens
import Data.Profunctor (dimap)
import Halogen as H
import Halogen.Component.Profunctor (ProComponent(..))
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Numeric as N
import Utils (stringToInt, chunksOf)

data Query a
  = Init a
  | ChangePlace Int a

type State =
  { digits ∷ Array Int
  , place ∷ Int
  }

type DSL = H.ComponentDSL State Query (Maybe N.Place) Slam
type HTML = H.ComponentHTML Query

component ∷ (Int → Int → Int) → ProComponent HH.HTML Query Slam (Maybe N.Place) (Maybe N.Place)
component operation =
  ProComponent $ H.lifecycleComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
  initialState ∷ Maybe (N.Place) → State
  initialState = { digits: [], place: _ } ∘ case _ of
    Just (N.Place n) → clamp (-10) 10 n
    Nothing → 0

  render ∷ State → HTML
  render st =
    HH.div
      [ HP.classes [ HH.ClassName "sd-place-value-picker" ] ]
      [ HH.label_ [ HH.text "Place" ]
      , HH.p
          [ HP.classes [ HH.ClassName "place-value" ] ]
          (renderNumber st.digits st.place)
      , HH.p_
          [ HH.input
              [ HP.type_ HP.InputRange
              , HP.prop (HH.PropName "min") (-10)
              , HP.prop (HH.PropName "max") 10
              , HP.value (show (-st.place))
              , HE.onValueInput (map (H.action ∘ ChangePlace ∘ negate) ∘ stringToInt)
              ]
          ]
      ]

  bold ∷ String → HTML
  bold a = HH.b_ [ HH.text a ]

  renderNumber ∷ Array Int → Int → Array HTML
  renderNumber ds n =
    let
      pivotIx = 10 + n
      digitIx = pivotIx + 1
      fn      = operation $ fromMaybe 0 $ Array.index ds pivotIx
      ds'     = flip Array.mapWithIndex ds case _, _ of
                  ix, val | ix ≡ digitIx → bold $ show (fn val)
                          | ix < digitIx → HH.text "0"
                          | otherwise    → HH.text $ show val
      nths    = Array.reverse $ Array.take 11 ds'
      ns      = Array.reverse $ F.intercalate [ HH.text "," ] $ chunksOf 3 (Array.drop 11 ds')
    in
      ns <> [ HH.text "." ] <> nths

  eval ∷ Query ~> DSL
  eval = case _ of
    Init next → do
      digits ← genDigits
      H.modify _ { digits = digits }
      pure next
    ChangePlace n next → do
      H.modify _ { place = n }
      H.raise (Just (N.Place n))
      pure next

genDigits ∷ DSL (Array Int)
genDigits =
  -- We only do 1 - 8 to simplify the operation
  H.liftEff $ sequence (Array.replicate 23 (randomInt 1 8))

transformFloor ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformFloor =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Floor))
    (map (T.Numeric ∘ N.Floor))
    (component (const id))

transformRound ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformRound =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Round))
    (map (T.Numeric ∘ N.Round))
    (component \n → if n < 5 then id else (_ + 1))

transformCeil ∷ H.Component HH.HTML Query (Maybe T.Transform) (Maybe T.Transform) Slam
transformCeil =
  unwrap $ dimap
    (Lens.preview (Lens._Just ∘ T._Numeric ∘ N._Ceil))
    (map (T.Numeric ∘ N.Ceil))
    (component (const (_ + 1)))


try child component

try child component

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Aff.Console (log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Except (ExceptT(..), runExceptT)
import Control.Monad.Except.Trans (class MonadTrans)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (class DecodeJson, Json, decodeJson)
import Data.Array (fold, singleton)
import Data.Either (either)
import Data.Lens (Lens', Prism', lens, over, prism')
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid as L
import Data.StrMap (StrMap)
import Data.StrMap as M
import Data.Tuple (Tuple(..), uncurry)
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite (Render)
import Thermite as T

data StoryAction

data Action = RootDidMount
            | StoryAction Int StoryAction

type Story = { title :: String }

type State = { topStories :: StrMap Story
             , topStoryIds :: List Int }

genFakeStory :: Int -> Story
genFakeStory id = { title: "Fake Story Title " <> show id }

initState :: State
initState = { topStories: M.empty
            , topStoryIds: L.mempty
            }

_topStoryIds :: Lens' State (List Int)
_topStoryIds = lens _.topStoryIds (_ { topStoryIds = _})

_StoryAction :: Prism' Action (Tuple Int StoryAction)
_StoryAction = prism' (uncurry StoryAction) \a ->
  case a of
    (StoryAction idx sa)-> Just (Tuple idx sa)
    _ -> Nothing

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

-- TODO replace string with story
storyItemSpec :: forall eff. T.Spec eff Int Unit StoryAction
storyItemSpec = T.simpleSpec T.defaultPerformAction render
  where
    render :: Render Int Unit StoryAction
    render dispatch _ id _ = singleton $ R.div' [ R.text $ show id ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

parseOrThrow :: forall m a. MonadThrow Error m => DecodeJson a => Json -> m a
parseOrThrow json = either (throwError <<< error) pure $ decodeJson json

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  result <- runExceptT do
    liftAff $ log "Fetching Top Stories..."
    res <- liftAff $ Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"

    liftAff $ log "Parsing Json..."
    -- demo of error throw catch
    -- _ <- throwError $ error "test error"
    ids <- liftAff $ parseOrThrow res.response

    liftAff $ log "Update State..."
    r <- lift $ T.modifyState \s -> s { topStoryIds = ids }

    liftAff $ log "Done!"
    pure r

  either
    (\e -> lift $ log $ "Caught error: \n" <> show e)
    (\r -> pure unit)
    result

  where
    liftAff :: forall eff1 m a
             . MonadTrans m
            => Aff eff1 a
            -> ExceptT Error (m (Aff eff1)) a
    liftAff = ExceptT <<< lift <<< attempt

  -- eitherIds <- lift $ attempt $ do
  --   res <- Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"
  --   parseOrThrow res.response
  -- case eitherIds of
  --   Right ids -> void $ T.modifyState \s -> s { topStoryIds = ids }
  --   Left error -> lift $ logShow error

performAction _ _ _ = pure unit

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = container $ fold
  [ stories
  , actions
  ]
  where
    container = over T._render \render d p s c ->
      [ R.p' [ R.text "Hello thermite!!" ]
      , R.div' $ render d p s c
      ]

    stories = T.focus _topStoryIds _StoryAction $
      T.foreach \_ -> storyItemSpec

    actions = T.simpleSpec performAction T.defaultRender

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Aff.Console (log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Except (ExceptT(..), runExceptT)
import Control.Monad.Except.Trans (class MonadTrans)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (class DecodeJson, Json, decodeJson)
import Data.Array ((..))
import Data.Either (either)
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite as T

data Action = RootDidMount

type Story = { title :: String }

type State = { topStories :: Array Story
             , topStoryIds :: Array Int }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)
            , topStoryIds: []
            }

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

parseOrThrow :: forall m a. MonadThrow Error m => DecodeJson a => Json -> m a
parseOrThrow json = either (throwError <<< error) pure $ decodeJson json

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  result <- runExceptT do
    liftAff $ log "Fetching Top Stories..."
    res <- liftAff $ Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"

    liftAff $ log "Parsing Json..."
    -- demo of error throw catch
    -- _ <- throwError $ error "test error"
    ids <- liftAff $ parseOrThrow res.response

    liftAff $ log "Update State..."
    r <- lift $ T.modifyState \s -> s { topStoryIds = ids }

    liftAff $ log "Done!"
    pure r

  either
    (\e -> lift $ log $ "Caught error: \n" <> show e)
    (\r -> pure unit)
    result

  where
    liftAff :: forall eff1 m a
             . MonadTrans m
            => Aff eff1 a
            -> ExceptT Error (m (Aff eff1)) a
    liftAff = ExceptT <<< lift <<< attempt

  -- eitherIds <- lift $ attempt $ do
  --   res <- Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"
  --   parseOrThrow res.response
  -- case eitherIds of
  --   Right ids -> void $ T.modifyState \s -> s { topStoryIds = ids }
  --   Left error -> lift $ logShow error

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList <<< map genFakeStory $ state.topStoryIds
  ]

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = T.simpleSpec performAction render

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"


Add checking for game end

Add checking for game end

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded ->
      id
  where
  setCountdown x game = game {countdown = x}

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

endGame :: GameUpdateM Unit
endGame =
  applyGameUpdateM GameEnded

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap (snd <$> starts)
  , countdown: Just 90
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \iId -> do
    eat iId
    changeScore pId (p ^. pScore + 1)

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  when (isEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
makeItems :: LevelMap -> [Position] -> [Item]
makeItems levelmap excludes =
  Tuple <$> r <*> r >>= \(Tuple x y) ->
    let pos = tilePositionToBlock (Position {x: x, y: y})
    in if shouldHaveDot pos
         then [Item { itemType: LittleDot, position: pos }]
         else []
  where
  r = range 0 (tilesAlongSide - 1)
  shouldHaveDot pos = isFree levelmap pos && not (elem pos excludes)

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

isEnded :: Game -> Boolean
isEnded g = M.isEmpty g.items

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe ItemId
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just (i ^. _1)
      _   -> Nothing

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
  where
  setCountdown x game = game {countdown = x}

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap (snd <$> starts)
  , countdown: Just 90
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \iId -> do
    eat iId
    changeScore pId (p ^. pScore + 1)

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
makeItems :: LevelMap -> [Position] -> [Item]
makeItems levelmap excludes =
  Tuple <$> r <*> r >>= \(Tuple x y) ->
    let pos = tilePositionToBlock (Position {x: x, y: y})
    in if shouldHaveDot pos
         then [Item { itemType: LittleDot, position: pos }]
         else []
  where
  r = range 0 (tilesAlongSide - 1)
  shouldHaveDot pos = isFree levelmap pos && not (elem pos excludes)

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe ItemId
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just (i ^. _1)
      _   -> Nothing


Keep track of current player in game state

module Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import Graphics.Canvas
import Math
import Prelude

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if ((even x) && (odd y)) || ((even y) && (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

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

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = {
  x: square.x,
  y: square.y,
  rx: square.rx,
  ry: square.ry,
  color: square.color,
  piece: piece }

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

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                                 y: square.ry + 0.5 * renderSize,
                                 r: (renderSize / 2.0) * 0.8,
                                 start: 0.0,
                                 end: 2.0 * pi }
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Eff (st :: ST s, canvas :: Canvas | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize,
                     h: (toNumber state.grid.height) * renderSize }
  return unit

main :: forall s e. (Eff (st :: ST s, canvas :: Canvas | e) Unit)
main = do
  st <- newSTRef {
    grid: (createGrid 8 8 3),
    currentPlayer: 1
  }
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit

module Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import Graphics.Canvas
import Math
import Prelude

type Coordinate = Tuple Int Int

type Player = String

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if ((even x) && (odd y)) || ((even y) && (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

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

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = {
  x: square.x,
  y: square.y,
  rx: square.rx,
  ry: square.ry,
  color: square.color,
  piece: piece }

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

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                                 y: square.ry + 0.5 * renderSize,
                                 r: (renderSize / 2.0) * 0.8,
                                 start: 0.0,
                                 end: 2.0 * pi }
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Eff (st :: ST s, canvas :: Canvas | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize,
                     h: (toNumber state.grid.height) * renderSize }
  return unit

main :: forall s e. (Eff (st :: ST s, canvas :: Canvas | e) Unit)
main = do
  st <- newSTRef { grid: (createGrid 8 8 3) }
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit


Minor indentation fix

Minor indentation fix

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Types

defaultWidth    = 8
defaultHeight   = 8
layerCount      = 3
renderSize      = 60.0
renderWidth     = (toNumber defaultWidth) * renderSize
renderHeight    = (toNumber defaultHeight) * renderSize
renderDimension = { width: renderWidth, height: renderHeight }

colorSquareOne  = "#d18b47"
colorSquareTwo  = "#ffce9e"
colorPlayerOne  = "red"
colorPlayerTwo  = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

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

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

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

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  square.rx < x && x < square.rx + renderSize &&
  square.ry < y && y < square.ry + renderSize

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

renderSquare :: forall e. Context2D -> Maybe DOMEvent -> Unit -> Square -> Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

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

renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseMoveEvent (onMouseMoveListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Avoid conflicts when using Control.Monad.Eff.Console.log and Math.log

module Main (main) where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if ((even x) && (odd y)) || ((even y) && (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

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

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

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

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

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                                 y: square.ry + 0.5 * renderSize,
                                 r: (renderSize / 2.0) * 0.8,
                                 start: 0.0,
                                 end: 2.0 * pi }
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Eff (st :: ST s, canvas :: Canvas | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize,
                     h: (toNumber state.grid.height) * renderSize }
  return unit

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

renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions { "width": 800.0, "height": 800.0 } canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState 8 8 3)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseOverEvent (onMouseOverListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Main (main) where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math
import Prelude

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

renderSize = 60.0
colorSquareOne = "#d18b47"
colorSquareTwo = "#ffce9e"
colorPlayerOne = "red"
colorPlayerTwo = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
  squares = do
    x <- 0 .. (width - 1)
    y <- 0 .. (height - 1)
    let rx = (toNumber x) * renderSize
        ry = (toNumber y) * renderSize
        color = if ((even x) && (odd y)) || ((even y) && (odd x))
                then colorSquareOne
                else colorSquareTwo
        hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
        piece = if hasPlayerOne
                then Just { color: colorPlayerOne }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  else Nothing
    return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

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

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

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

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

renderSquare :: forall e. Context2D -> Unit -> Square -> Eff (canvas :: Canvas | e) Unit
renderSquare ctx _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        fillPath ctx $ arc ctx { x: square.rx + 0.5 * renderSize,
                                 y: square.ry + 0.5 * renderSize,
                                 r: (renderSize / 2.0) * 0.8,
                                 start: 0.0,
                                 end: 2.0 * pi }
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Eff (st :: ST s, canvas :: Canvas | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize,
                     h: (toNumber state.grid.height) * renderSize }
  return unit

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

renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions { "width": 800.0, "height": 800.0 } canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState 8 8 3)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseOverEvent (onMouseOverListener st) canvas
      renderPage st
      return unit
    _ -> return unit


Eliminate errors

Eliminate errors

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
-- import React as R
import React (ReactElement)
import React.DOM as R
-- import React.DOM.Props as RP
-- import ReactDOM as RDOM
import Thermite as T
import DOM (DOM)
import Data.Array ((..))

data Action

type Story = { title :: String
             }

type State = { topStories :: Array Story }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)}

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList state.topStories
  ]

spec :: forall eff. T.Spec eff State Unit Action
spec = T.simpleSpec T.defaultPerformAction render

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  T.defaultMain spec initState unit
  log "Hello from main"

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import React as R
import React (ReactElement)
import React.DOM as R
import React.DOM.Props as RP
import ReactDOM as RDOM
import Thermite as T
import DOM (DOM)
import Data.Array ((..))

data Action

type Story = { title :: String
             }

type State = { topStories :: Array Story }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)}

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

render :: T.Render State _ Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList state.topStories
  ]

performAction :: T.PerformAction _ State _ Action
performAction _ _ _ = void $ pure unit

spec :: T.Spec _ State _ Action
spec = T.simpleSpec performAction render

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  T.defaultMain spec initState unit
  log "Hello from main"