pull functions out of where clauses

pull functions out of where clauses

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in space and time linear to the length of the string.
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in space and time linear to the
-- | length of the string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Returns a record with strings created from the code points on either side
-- | of the given index. If the index is not within the string, Nothing is
-- | returned.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in space and time linear to the
-- | given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in space and time
-- | linear to the length of the string.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s' = (\{ head, tail } -> Tuple head tail) <$> uncons s'

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0
  where
  countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
  countTail p' s' accum = case uncons s' of
    Just { head, tail } -> if p' head then countTail p' tail (accum + 1) else accum
    _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in space and time linear to the length of the string.
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in space and time linear to the
-- | length of the string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Returns a record with strings created from the code points on either side
-- | of the given index. If the index is not within the string, Nothing is
-- | returned.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in space and time linear to the
-- | given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in space and time
-- | linear to the length of the string.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode s
  where
  decode :: String -> Maybe (Tuple CodePoint String)
  decode s' = (\{ head, tail } -> Tuple head tail) <$> uncons s'

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }


Rename stackEqual to stackEqualColumns. Closes #20

module Levels.Chapter1 where

import Data.Array
import Data.Maybe
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

-- | concat adjacent lists if they are equal
stackEqual :: Transformer
stackEqual [] = []
stackEqual (s:ss) = concat (s:split.init) : stackEqual split.rest
    where split = span (== s) ss

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: SM.fromList [
        "replaceYbyB" :> {
            name: "map {Yellow}↦{Brown}",
            function: replaceSingle Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map {Yellow}↦{Brown}{Yellow}",
            function: replaceMultiple Yellow [Brown, Yellow]
        },
        "replaceBbyOO" :> {
            name: "map {Brown}↦{Orange}{Orange}",
            function: replaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "map (reject {Orange})",
            function: map (reject (== Orange)) >>> clearEmpty
        },
        "pushY" :> {
            name: "map (stack {Yellow})",
            function: map (`snoc` Yellow)
        },
        "stackEqual" :> {
            name: "stackEqualColumns",
            function: stackEqual
        }
    ],

    levels: SM.fromList [
        "1.1" :> {
            name: "Dismiss",
            help: Just """In this game, your goal is to create a sequence of functions which
                          transforms the stack of cubes into the desired pattern shown above.
                          To solve this level, add the `rejectO` function to your program by
                          dragging it to the list on the right side.""",
            difficulty: Easy,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1.2" :> {
            name: "Gizeh",
            help: Nothing,
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown, Brown, Brown, Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown]]
        },
        "1.3" :> {
            name: "Poseidon",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Brown], [Brown, Brown, Brown, Brown], [Brown], [Brown, Brown]]
        },
        "1.4" :> {
            name: "Bowl",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        },
        "1.5" :> {
            name: "Stamp",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Yellow], [Yellow], [Yellow, Yellow, Yellow, Yellow], [Yellow], [Yellow]]
        }
    ]
}

module Levels.Chapter1 where

import Data.Array
import Data.Maybe
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

-- | concat adjacent lists if they are equal
stackEqual :: Transformer
stackEqual [] = []
stackEqual (s:ss) = concat (s:split.init) : stackEqual split.rest
    where split = span (== s) ss

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: SM.fromList [
        "replaceYbyB" :> {
            name: "map {Yellow}↦{Brown}",
            function: replaceSingle Yellow Brown
        },
        "replaceYbyBY" :> {
            name: "map {Yellow}↦{Brown}{Yellow}",
            function: replaceMultiple Yellow [Brown, Yellow]
        },
        "replaceBbyOO" :> {
            name: "map {Brown}↦{Orange}{Orange}",
            function: replaceMultiple Brown [Orange, Orange]
        },
        "rejectO" :> {
            name: "map (reject {Orange})",
            function: map (reject (== Orange)) >>> clearEmpty
        },
        "pushY" :> {
            name: "map (stack {Yellow})",
            function: map (`snoc` Yellow)
        },
        "stackEqual" :> {
            name: "stackEqual",
            function: stackEqual
        }
    ],

    levels: SM.fromList [
        "1.1" :> {
            name: "Dismiss",
            help: Just """In this game, your goal is to create a sequence of functions which
                          transforms the stack of cubes into the desired pattern shown above.
                          To solve this level, add the `rejectO` function to your program by
                          dragging it to the list on the right side.""",
            difficulty: Easy,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]
        },
        "1.2" :> {
            name: "Gizeh",
            help: Nothing,
            difficulty: Medium,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown, Brown, Brown, Brown, Brown], [Orange, Brown, Orange, Brown], [Brown, Brown]]
        },
        "1.3" :> {
            name: "Poseidon",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Brown, Brown], [Brown], [Brown, Brown, Brown, Brown], [Brown], [Brown, Brown]]
        },
        "1.4" :> {
            name: "Bowl",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Brown]],
            target: [[Orange, Orange, Orange, Orange], [Orange, Orange], [Orange, Orange], [Orange, Orange, Orange, Orange]]
        },
        "1.5" :> {
            name: "Stamp",
            help: Nothing,
            difficulty: Hard,
            initial: [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]],
            target: [[Yellow], [Yellow], [Yellow, Yellow, Yellow, Yellow], [Yellow], [Yellow]]
        }
    ]
}


Add more request options

Add more request options

This patch adds some more request options I'd like to have.

Signed-off-by: Joe Grund <5a0004131f5af71cc30270f318d2c30ba7aaa99a@intel.com>

-- | This module defines low-level bindings to the Node HTTP client.

module Node.HTTP.Client
  ( Request()
  , Response()
  , RequestHeaders(..)
  , RequestOptions()
  , RequestFamily(..)
  , protocol
  , hostname
  , port
  , method
  , path
  , headers
  , auth
  , key
  , cert
  , rejectUnauthorized
  , family
  , request
  , requestFromURI
  , requestAsStream
  , responseAsStream
  , setTimeout
  , httpVersion
  , responseHeaders
  , responseCookies
  , statusCode
  , statusMessage
  ) where

import Prelude (Unit, (<<<), ($))

import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe)
import Data.Foreign (Foreign, toForeign)
import Data.Options (Options, Option, options, opt)
import Data.StrMap (StrMap(), delete, lookup)
import Data.Functor.Contravariant ((>$<))
import Node.HTTP (HTTP())
import Node.Stream (Readable, Writable)
import Node.URL as URL
import Unsafe.Coerce (unsafeCoerce)

-- | A HTTP request object
foreign import data Request :: *

-- | A HTTP response object
foreign import data Response :: *

-- | A HTTP request object
newtype RequestHeaders = RequestHeaders (StrMap String)

-- | The type of HTTP request options
data RequestOptions

-- | Values for the `family` request option
data RequestFamily = IPV4 | IPV6

-- | The protocol to use
protocol :: Option RequestOptions String
protocol = opt "protocol"

-- | Domain name or IP
hostname :: Option RequestOptions String
hostname = opt "hostname"

-- | Port of remote server
port :: Option RequestOptions Int
port = opt "port"

-- | The HTTP request method: GET, POST, etc.
method :: Option RequestOptions String
method = opt "method"

-- | The request path, including query string if appropriate.
path :: Option RequestOptions String
path = opt "path"

headers :: Option RequestOptions RequestHeaders
headers = opt "headers"

-- | Basic authentication
auth :: Option RequestOptions String
auth = opt "auth"

-- | Private Key
key :: Option RequestOptions String
key = opt "key"

-- | Public x509 certificate
cert :: Option RequestOptions String
cert = opt "cert"

-- | Is cert verified against CAs
rejectUnauthorized :: Option RequestOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | IP address family to use when resolving `hostname`.
-- | Valid values are `IPV6` and `IPV4`
family :: Option RequestOptions RequestFamily
family = familyToOption >$< opt "family"

-- | Translates RequestFamily values to Int parameters for Request
familyToOption :: RequestFamily -> Int
familyToOption IPV4 = 4
familyToOption IPV6 = 6

-- | Make a HTTP request using the specified options and response callback.
foreign import requestImpl :: forall eff. Foreign -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request

-- | Make a HTTP request using the specified options and response callback.
request :: forall eff. Options RequestOptions -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request
request = requestImpl <<< options

-- | Make a HTTP request from a URI string and response callback.
requestFromURI :: forall eff. String -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request
requestFromURI = requestImpl <<< toForeign <<< URL.parse

-- | Create a writable stream from a request object.
requestAsStream :: forall eff r. Request -> Writable r (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Create a readable stream from a response object.
responseAsStream :: forall eff w. Response -> Readable w (http :: HTTP | eff)
responseAsStream = unsafeCoerce

-- | Set the socket timeout for a `Request`
foreign import setTimeout :: forall eff. Request -> Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Get the request HTTP version
httpVersion :: Response -> String
httpVersion = _.httpVersion <<< unsafeCoerce

headers' :: forall a. Response -> StrMap a
headers' = _.headers <<< unsafeCoerce

-- | Get the response headers as a hash
-- | Cookies are not included and could be retrieved with responseCookies
responseHeaders :: Response -> StrMap String
responseHeaders res = delete "set-cookie" $ headers' res

-- | Get the response cookies as Just (Array String) or Nothing if no cookies
responseCookies :: Response -> Maybe (Array String)
responseCookies res = lookup "set-cookie" $ headers' res

-- | Get the response status code
statusCode :: Response -> Int
statusCode = _.statusCode <<< unsafeCoerce

-- | Get the response status message
statusMessage :: Response -> String
statusMessage = _.statusMessage <<< unsafeCoerce

-- | This module defines low-level bindings to the Node HTTP client.

module Node.HTTP.Client
  ( Request()
  , Response()
  , RequestHeaders(..)
  , RequestOptions()
  , RequestFamily(..)
  , protocol
  , hostname
  , port
  , method
  , path
  , headers
  , auth
  , family
  , request
  , requestFromURI
  , requestAsStream
  , responseAsStream
  , setTimeout
  , httpVersion
  , responseHeaders
  , responseCookies
  , statusCode
  , statusMessage
  ) where

import Prelude (Unit, (<<<), ($))

import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe)
import Data.Foreign (Foreign, toForeign)
import Data.Options (Options, Option, options, opt)
import Data.StrMap (StrMap(), delete, lookup)
import Data.Functor.Contravariant ((>$<))
import Node.HTTP (HTTP())
import Node.Stream (Readable, Writable)
import Node.URL as URL
import Unsafe.Coerce (unsafeCoerce)

-- | A HTTP request object
foreign import data Request :: *

-- | A HTTP response object
foreign import data Response :: *

-- | A HTTP request object
newtype RequestHeaders = RequestHeaders (StrMap String)

-- | The type of HTTP request options
data RequestOptions

-- | Values for the `family` request option
data RequestFamily = IPV4 | IPV6

-- | The protocol to use
protocol :: Option RequestOptions String
protocol = opt "protocol"

-- | Domain name or IP
hostname :: Option RequestOptions String
hostname = opt "hostname"

-- | Port of remote server
port :: Option RequestOptions Int
port = opt "port"

-- | The HTTP request method: GET, POST, etc.
method :: Option RequestOptions String
method = opt "method"

-- | The request path, including query string if appropriate.
path :: Option RequestOptions String
path = opt "path"

headers :: Option RequestOptions RequestHeaders
headers = opt "headers"

-- | Basic authentication
auth :: Option RequestOptions String
auth = opt "auth"

-- | IP address family to use when resolving `hostname`.
-- | Valid values are `IPV6` and `IPV4`
family :: Option RequestOptions RequestFamily
family = familyToOption >$< opt "family"

-- | Translates RequestFamily values to Int parameters for Request
familyToOption :: RequestFamily -> Int
familyToOption IPV4 = 4
familyToOption IPV6 = 6

-- | Make a HTTP request using the specified options and response callback.
foreign import requestImpl :: forall eff. Foreign -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request

-- | Make a HTTP request using the specified options and response callback.
request :: forall eff. Options RequestOptions -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request
request = requestImpl <<< options

-- | Make a HTTP request from a URI string and response callback.
requestFromURI :: forall eff. String -> (Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Request
requestFromURI = requestImpl <<< toForeign <<< URL.parse

-- | Create a writable stream from a request object.
requestAsStream :: forall eff r. Request -> Writable r (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Create a readable stream from a response object.
responseAsStream :: forall eff w. Response -> Readable w (http :: HTTP | eff)
responseAsStream = unsafeCoerce

-- | Set the socket timeout for a `Request`
foreign import setTimeout :: forall eff. Request -> Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Get the request HTTP version
httpVersion :: Response -> String
httpVersion = _.httpVersion <<< unsafeCoerce

headers' :: forall a. Response -> StrMap a
headers' = _.headers <<< unsafeCoerce

-- | Get the response headers as a hash
-- | Cookies are not included and could be retrieved with responseCookies
responseHeaders :: Response -> StrMap String
responseHeaders res = delete "set-cookie" $ headers' res

-- | Get the response cookies as Just (Array String) or Nothing if no cookies
responseCookies :: Response -> Maybe (Array String)
responseCookies res = lookup "set-cookie" $ headers' res

-- | Get the response status code
statusCode :: Response -> Int
statusCode = _.statusCode <<< unsafeCoerce

-- | Get the response status message
statusMessage :: Response -> String
statusMessage = _.statusMessage <<< unsafeCoerce


Transitions can schedule further transitions

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall d. Selection d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove


Clean up a bit.  Allow the game to be restarted once it finishes.

{- -*- Mode: Haskell -*- -}

module Asteroids where

import Math
import Debug.Trace
import Control.Monad
import Control.MonadPlus
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.ST
import Graphics.Canvas

import Data.Array
import Data.Tuple
import Data.Foldable
import Data.Maybe.Unsafe
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.DOM.Simple.Events

data Phase = GameOver | Playing Ship | Crashing Ship Number | Respawning Number

type Moveable m = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number | m }

type Ship = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , dir  :: Number
    }

type Asteroid = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , path :: [Number]
    }

type Missile = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , fuse :: Number
    }

type Controls = {
      thrust :: Number
    , left   :: Boolean
    , right  :: Boolean
    }

type State = {
      w         :: Number
    , h         :: Number
    , phase     :: Phase
    , nships    :: Number
    , score     :: Number
    , asteroids :: [Asteroid]
    , missiles  :: [Missile]
    , controls  :: Controls
    }

main :: forall s e. Eff ( st :: ST s, dom :: DOM, canvas :: Canvas, random :: Random, trace :: Trace | e ) Unit
main = do
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow

  let ship = defaultShip w h
      controls = { thrust: 0, left: false, right: false }

  asteroids <- replicateM 10 (randomAsteroid w h)

  st <- newSTRef { w: w, h: h
                 , phase: GameOver
                 , nships: 3
                 , score: 0
                 , asteroids: asteroids
                 , missiles: [ ]
                 , controls: controls }

  resize st
  addUIEventListener ResizeEvent (resize0 st) globalWindow

  addKeyboardEventListener KeydownEvent (keydown st) globalWindow
  addKeyboardEventListener KeyupEvent (keyup st) globalWindow
  addKeyboardEventListener KeypressEvent (keypress st) globalWindow

  setInterval globalWindow 33 $ tick st

  return unit

-- |Returns a new ship in the middle of the canvas.
defaultShip :: Number -> Number -> Ship
defaultShip w h = { x: w / 2, y: w / 2, dir: 0, dx: 0, dy: 0, r: 10 }

-- |The maximum speed we'll allow for a ship.
maxSpeed = 6.0

-- |Creates a randomly located asteroid somewhere on the canvas.
randomAsteroid :: forall e. Number -> Number -> Eff ( random :: Random | e ) Asteroid
randomAsteroid w h = do
  x  <- randomRange 0 w
  y  <- randomRange 0 h
  dx <- (*) <$> (randomRange 1 2) <*> randomSign
  dy <- (*) <$> (randomRange 1 2) <*> randomSign
  path <- replicateM 12 (randomRange 0.7 1.1)
  return { x: x, y: y, dx: dx, dy: dy, r: 50, path: path }
      where randomRange lo hi = (\n -> lo + n * (hi - lo)) <$> random
            randomSign = (\n -> if n < 0.5 then (-1) else 1) <$> random

-- |Thunk to attach resize to the ResizeEvent
-- XXX WTF? Why do I need this?
resize0 :: forall s e. STRef s State -> DOMEvent -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize0 st _ = resize st

-- |Handles window resizing by stretching the canvas to fit the
-- viewport and updating our notion of how large the canvas is.
resize :: forall s e. STRef s State -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize st = do
  state <- readSTRef st
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow
  canvas <- getCanvasElementById "canvas"
  setCanvasWidth w canvas
  setCanvasHeight h canvas
  modifySTRef st $ (\state -> state { w = w, h = h })
  return unit

-- |Handles key presses for keys that can be held down.
keydown :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keydown st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = true }
                       83  -> state.controls { right = true }
                       75  -> state.controls { thrust = 0.5 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles key releases for keys that can be held down.
keyup :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keyup st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = false }
                       83  -> state.controls { right = false }
                       75  -> state.controls { thrust = 0.0 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles single key presses.
keypress :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM, random :: Random | e) Unit
keypress st event = do
  state <- readSTRef st
  k <- key event
  case state.phase of
    Playing ship | (k == "l" || k == "L") -> do
      let x = ship.x
          y = ship.y
          dx = ship.dx + 8 * cos (ship.dir - pi/2)
          dy = ship.dy + 8 * sin (ship.dir - pi/2)
          missile = { x: x, y: y, dx: dx, dy: dy, r: 1, fuse: 50 }

      writeSTRef st $ state { missiles = (missile : state.missiles) }
      return unit

    GameOver | (k == " ") -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      writeSTRef st $ state { phase     = Respawning 11
                            , nships    = 3
                            , score     = 0
                            , asteroids = asteroids
                            }
      return unit

    _ -> return unit

-- |Handles a single animation frame.
tick :: forall s e. STRef s State -> Eff (st :: ST s, random :: Random, canvas :: Canvas | e ) Unit
tick st = do
  state <- readSTRef st
  state' <- update state
  writeSTRef st state'
  render state

-- |Updates the world state.
update :: forall s e. State -> Eff (st :: ST s, random :: Random | e) State
update state = do
  let -- These asteroids haven't been hit.
      asteroids = do
        a <- state.asteroids
        guard $ not (any (flip hittest $ a) state.missiles)
        [move state.w state.h a]

      -- These asteroids have been hit: split 'em.
      asteroids' = do
        a <- state.asteroids
        case filter (flip hittest $ a) state.missiles of
          (m : ms) ->
              if a.r >= 20
              then let dx = m.dx / 10
                       dy = m.dy / 10
                   in [ a { dx = (dx + 1.5 * a.dy), dy = (dy + 1.5 * a.dx), r = a.r / 2 },
                        a { dx = (dx - 1.5 * a.dy), dy = (dy - 1.5 * a.dx), r = a.r / 2 } ]
              else [ ]

          _ -> [ ]

      asteroids'' = asteroids ++ asteroids'

      -- Remove any missiles that hit something.
      missiles = do
        m <- state.missiles
        guard $ not (any (hittest m) state.asteroids)
        let m' = burn m
        guard $ m'.fuse > 0
        [move state.w state.h m']

  case state.phase of
    Playing ship | length asteroids'' > 0 -> do
      let c = state.controls

          -- Update the ship based on any controls.
          dir = ship.dir + (if c.right then (pi / 16) else 0.0) + (if c.left then (-pi / 16) else 0.0)
          dx = clamp (-maxSpeed) maxSpeed (ship.dx + c.thrust * cos (dir - pi/2))
          dy = clamp (-maxSpeed) maxSpeed (ship.dy + c.thrust * sin (dir - pi/2))
          x = (state.w + ship.x + ship.dx) % state.w
          y = (state.h + ship.y + ship.dy) % state.h
          ship' = ship { x = x, y = y, dx = dx, dy = dy, dir = dir }

          -- Accumulate points for any hit asteroids
          points = sum $ do
            a <- state.asteroids
            guard $ any (flip hittest $ a) state.missiles
            [if a.r >= 50 then 20 else if a.r >= 25 then 50 else 100]

          -- Did the ship crash?
          crash = any (hittest ship') asteroids

      return $ state { phase     = if crash then Crashing ship' 0 else Playing ship'
                     , nships    = if crash then state.nships - 1 else state.nships
                     , missiles  = missiles
                     , asteroids = asteroids''
                     , score     = state.score + points
                     }

    Playing ship -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      return $ state { phase     = Respawning 33
                     , asteroids = asteroids
                     , missiles  = [ ] }

    Crashing ship step -> do
      let ship' = ship { x = (state.w + ship.x + ship.dx) % state.w,
                         y = (state.h + ship.y + ship.dy) % state.h }
          phase = if step > 33 then
                      if state.nships > 0 then Respawning 33 else GameOver
                  else Crashing ship' (step + 1)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n | n > 0 -> do
      return $ state { phase = Respawning (n-1)
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n -> do
      let center = (defaultShip state.w state.h) { r = 40 }
          phase = if any (hittest center) state.asteroids
                  then Respawning n
                  else Playing (defaultShip state.w state.h)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    GameOver -> do
      return $ state { missiles  = missiles
                     , asteroids = asteroids'' }

-- |Ticks down the fuse on a missile.
burn :: forall m. { fuse :: Number | m } -> { fuse :: Number | m }
burn missile = missile { fuse = missile.fuse - 1.0 }

-- |Checks to see if two Moveable's have collided.
hittest :: forall m n. Moveable m -> Moveable n -> Boolean
hittest a b =
    let dx = a.x - b.x
        dy = a.y - b.y
    in sqrt ((dx * dx) + (dy * dy)) <= (a.r + b.r)

-- |Clamps the value of `x` between `lo` and `hi`.
clamp :: Number -> Number -> Number -> Number
clamp lo hi x = max lo (min hi x)

-- |Moves a Moveable by updating it's `x` and `y` coordinates by `dx`
-- and `dy`, respectively.
move :: forall m. Number -> Number -> Moveable m -> Moveable m
move w h obj = obj { x = (w + obj.x + obj.dx) % w
                   , y = (h + obj.y + obj.dy) % h }

-- |Renders the current state.
render :: forall e. State -> Eff ( canvas :: Canvas | e ) Unit
render state = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas
  setFillStyle "#000000" ctx
  fillPath ctx $ rect ctx { x: 0, y: 0, w: state.w, h: state.h }

  -- Draw the score
  save ctx
  setFillStyle "#ffffff" ctx
  setFont "16px Hyperspace" ctx
  fillText ctx (show state.score) 10 20
  restore ctx

  -- Draw the remaining ships
  forE 1 state.nships $ \i -> do
      let ship = (defaultShip 0 0) { x = 20 * i, y = 40 }
      renderShip ctx ship "#ffffff" false
      return unit

  case state.phase of
    Playing ship    -> renderShip ctx ship "#ffffff" (state.controls.thrust /= 0)
    Respawning _    -> renderShip ctx (defaultShip state.w state.h) "#555555" false
    Crashing ship i -> renderCrash ctx ship i
    GameOver        -> renderGameOver ctx state.w state.h

  foldM (renderAsteroid ctx) unit state.asteroids
  foldM (renderMissile ctx) unit state.missiles
  return unit

-- |Renders a ship.
renderShip :: forall e. Context2D -> Ship -> String -> Boolean -> Eff ( canvas :: Canvas | e ) Unit
renderShip ctx ship color engines = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle color ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  lineTo ctx 0 8
  lineTo ctx 7 10
  lineTo ctx 0 (-10)
  stroke ctx

  when engines $ do
    moveTo ctx (-4) 11
    lineTo ctx 0 15
    lineTo ctx 4 11
    stroke ctx
    return unit

  restore ctx
  return unit

-- |Renders an exploding ship.
renderCrash :: forall e. Context2D -> Ship -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderCrash ctx ship i = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle "#ffffff" ctx

  save ctx
  translate { translateX: -i, translateY: -i } ctx
  rotate (i * pi / 60) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: -i } ctx
  rotate ((-i) * pi / 30) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: -i, translateY: i } ctx
  rotate ((-i) * pi / 20) ctx
  beginPath ctx
  moveTo ctx (-7) 10
  lineTo ctx 0 8
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: i } ctx
  rotate (i * pi / 15) ctx
  beginPath ctx
  moveTo ctx 0 8
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  restore ctx

  return unit

-- |Renders an asteroid.
renderAsteroid :: forall e. Context2D -> Unit -> Asteroid -> Eff ( canvas :: Canvas | e ) Unit
renderAsteroid ctx _ asteroid = do
  save ctx

  setLineWidth 1 ctx
  translate { translateX: asteroid.x, translateY: asteroid.y } ctx
  setStrokeStyle "#ffffff" ctx
  beginPath ctx

  let n = length asteroid.path
      steps = map ((*) (2 * pi / n)) (1 .. n)
      theta = fromJust $ last steps
      off = fromJust $ last asteroid.path

  moveTo ctx (asteroid.r * off * cos theta) (asteroid.r * off * sin theta)

  for_ (zip asteroid.path steps) $ \(Tuple off theta) -> do
                                  let x = asteroid.r * off * cos theta
                                      y = asteroid.r * off * sin theta
                                  lineTo ctx x y

  stroke ctx

  restore ctx
  return unit

-- |Renders a missile.
renderMissile :: forall e. Context2D -> Unit -> Missile -> Eff ( canvas :: Canvas | e ) Unit
renderMissile ctx _ missile = do
  save ctx
  setFillStyle "#ffffff" ctx
  fillPath ctx $ arc ctx { x: missile.x, y: missile.y, r: 2, start: 0, end: 2 * pi }
  restore ctx
  return unit

-- |Renders the GAME OVER screen.
renderGameOver :: forall e. Context2D -> Number -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderGameOver ctx w h = do
  save ctx
  setFillStyle "#ffffff" ctx

  centerText "Game Over" 64 (-40)
  centerText "Controls" 20 0
  centerText "A = Rotate Left, S = Rotate Right" 14 20
  centerText "K = Thrust, L = Fire" 14 40
  centerText "Press the space bar to start" 16 120

  restore ctx
  return unit
      where centerText text pixels y = do
              setFont ((show pixels) ++ "px Hyperspace") ctx
              metrics <- measureText ctx text
              fillText ctx text (w / 2 - metrics.width / 2) (y + h / 2)

{- -*- Mode: Haskell -*- -}

module Asteroids where

import Math
import Debug.Trace
import Control.Monad
import Control.MonadPlus
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.ST
import Graphics.Canvas

import Data.Array
import Data.Tuple
import Data.Foldable
import Data.Maybe.Unsafe
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.DOM.Simple.Events

data Phase = GameOver | Playing Ship | Crashing Ship Number | Respawning Number

type Moveable m = {
      x :: Number
    , y :: Number
    , dx :: Number
    , dy :: Number
    , r :: Number | m }

type Ship = {
      x   :: Number
    , y   :: Number
    , dx  :: Number
    , dy  :: Number
    , r   :: Number
    , dir :: Number
    }

type Asteroid = {
      x :: Number
    , y :: Number
    , dx :: Number
    , dy :: Number
    , r :: Number
    , path :: [Number]
    }

type Missile = {
      x :: Number
    , y :: Number
    , dx :: Number
    , dy :: Number
    , r :: Number
    , fuse :: Number
    }

type Controls = {
      thrust :: Number
    , left   :: Boolean
    , right  :: Boolean
    }

type State = {
      w         :: Number
    , h         :: Number
    , phase     :: Phase
    , nships    :: Number
    , score     :: Number
    , asteroids :: [Asteroid]
    , missiles  :: [Missile]
    , controls  :: Controls
    }

main :: forall s e. Eff ( st :: ST s, dom :: DOM, canvas :: Canvas, random :: Random, trace :: Trace | e ) Unit
main = do
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow

  let ship = defaultShip w h
      controls = { thrust: 0, left: false, right: false }

  asteroids <- replicateM 10 (randomAsteroid w h)

  st <- newSTRef { w: w, h: h
                 , phase: Respawning 0
                 , nships: 3
                 , score: 0
                 , asteroids: asteroids
                 , missiles: [ ]
                 , controls: controls }

  resize st
  addUIEventListener ResizeEvent (resize0 st) globalWindow
  addKeyboardEventListener KeydownEvent (keydown st) globalWindow
  addKeyboardEventListener KeyupEvent (keyup st) globalWindow
  addKeyboardEventListener KeypressEvent (keypress st) globalWindow
  setInterval globalWindow 33 $ tick st
  return unit

defaultShip :: Number -> Number -> Ship
defaultShip w h = { x: w / 2, y: w / 2, dir: 0, dx: 0, dy: 0, r: 10 }

randomAsteroid :: forall e. Number -> Number -> Eff ( random :: Random | e ) Asteroid
randomAsteroid w h = do
  x <- ((*) w) <$> random
  y <- ((*) h) <$> random
  dx <- (*) <$> (randomRange 1 2) <*> randomSign
  dy <- (*) <$> (randomRange 1 2) <*> randomSign
  path <- replicateM 12 (randomRange 0.7 1.1)
  return { x: x, y: y, dx: dx, dy: dy, r: 50, path: path }
      where randomRange lo hi = do
                       n <- random
                       return $ lo + n * (hi - lo)
            randomSign = do
                       n <- random
                       return $ if n < 0.5 then (-1) else 1

-- XXX WTF? Why do I need this?
resize0 :: forall s e. STRef s State -> DOMEvent -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize0 st _ = resize st

resize :: forall s e. STRef s State -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize st = do
  state <- readSTRef st
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow
  canvas <- getCanvasElementById "canvas"
  setCanvasWidth w canvas
  setCanvasHeight h canvas
  modifySTRef st $ (\state -> state { w = w, h = h })
  return unit

keydown :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keydown st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = true }
                       83  -> state.controls { right = true }
                       75  -> state.controls { thrust = 0.5 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

keyup :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keyup st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = false }
                       83  -> state.controls { right = false }
                       75  -> state.controls { thrust = 0.0 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

keypress :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM, trace :: Trace | e) Unit
keypress st event = do
  k <- key event
  when (k == "l" || k == "L") fire
      where fire = do
              modifySTRef st $ \state ->
                  case state.phase of
                    Playing ship ->
                        let x = ship.x
                            y = ship.y
                            dx = ship.dx + 8 * cos (ship.dir - pi/2)
                            dy = ship.dy + 8 * sin (ship.dir - pi/2)
                            missile = { x: x, y: y, dx: dx, dy: dy, r: 1, fuse: 50 }
                        in state { missiles = (missile : state.missiles) }

                    _ -> state

              return unit

tick :: forall s e. STRef s State -> Eff (st :: ST s, random :: Random, canvas :: Canvas | e ) Unit
tick st = do
  update st
  render st

update :: forall s e. STRef s State -> Eff (st :: ST s, random :: Random | e) Unit
update st = do
  state <- readSTRef st
  let -- These asteroids haven't been hit.
      asteroids = do
        a <- state.asteroids
        guard $ not (any (flip hittest $ a) state.missiles)
        [move state.w state.h a]

      -- These asteroids have been hit: split 'em.
      asteroids' = do
        a <- state.asteroids
        case filter (flip hittest $ a) state.missiles of
          (m : ms) ->
              if a.r >= 20
              then let dx = m.dx / 10
                       dy = m.dy / 10
                   in [ a { dx = (dx + 1.5 * a.dy), dy = (dy + 1.5 * a.dx), r = a.r / 2 },
                        a { dx = (dx - 1.5 * a.dy), dy = (dy - 1.5 * a.dx), r = a.r / 2 } ]
              else [ ]

          _ -> [ ]

      asteroids'' = asteroids ++ asteroids'

      -- Remove any missiles that hit something.
      missiles = do
        m <- state.missiles
        guard $ not (any (hittest m) state.asteroids)
        let m' = burn m
        guard $ m'.fuse > 0
        [move state.w state.h m']

  case state.phase of
    Playing ship | length asteroids'' > 0 -> do
      let c = state.controls

          -- Update the ship based on any controls.
          dir = ship.dir + (if c.right then (pi / 16) else 0.0) + (if c.left then (-pi / 16) else 0.0)
          dx = clamp (-maxSpeed) maxSpeed (ship.dx + c.thrust * cos (dir - pi/2))
          dy = clamp (-maxSpeed) maxSpeed (ship.dy + c.thrust * sin (dir - pi/2))
          x = (state.w + ship.x + ship.dx) % state.w
          y = (state.h + ship.y + ship.dy) % state.h
          ship' = ship { x = x, y = y, dx = dx, dy = dy, dir = dir }

          -- Accumulate points for any hit asteroids
          points = sum $ do
            a <- state.asteroids
            guard $ any (flip hittest $ a) state.missiles
            [if a.r >= 50 then 20 else if a.r >= 25 then 50 else 100]

          -- Did the ship crash?
          crash = any (hittest ship') asteroids

      writeSTRef st $ state { phase     = if crash then Crashing ship' 0 else Playing ship'
                            , nships    = if crash then state.nships - 1 else state.nships
                            , missiles  = missiles
                            , asteroids = asteroids''
                            , score     = state.score + points
                            }

    Playing ship -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      writeSTRef st $ state { phase     = Respawning 33
                            , asteroids = asteroids
                            , missiles  = [ ] }

    Crashing ship step -> do
      let ship' = ship { x = (state.w + ship.x + ship.dx) % state.w,
                         y = (state.h + ship.y + ship.dy) % state.h }
          phase = if step > 33 then
                      if state.nships > 0 then Respawning 33 else GameOver
                  else Crashing ship' (step + 1)

      writeSTRef st $ state { phase     = phase
                            , missiles  = missiles
                            , asteroids = asteroids'' }

    Respawning n | n > 0 -> do
      writeSTRef st $ state { phase = Respawning (n-1)
                            , missiles  = missiles
                            , asteroids = asteroids'' }

    Respawning n -> do
      let center = (defaultShip state.w state.h) { r = 40 }
          phase = if any (hittest center) state.asteroids
                  then Respawning n
                  else Playing (defaultShip state.w state.h)

      writeSTRef st $ state { phase     = phase
                            , missiles  = missiles
                            , asteroids = asteroids'' }

    GameOver -> do
      writeSTRef st $ state { missiles = missiles
                            , asteroids = asteroids'' }

  return unit

        where
          burn :: forall m. { fuse :: Number | m } -> { fuse :: Number | m }
          burn missile = missile { fuse = missile.fuse - 1.0 }

          maxSpeed = 6.0

hittest :: forall m n. Moveable m -> Moveable n -> Boolean
hittest a b =
    let dx = a.x - b.x
        dy = a.y - b.y
    in sqrt ((dx * dx) + (dy * dy)) <= (a.r + b.r)

clamp :: Number -> Number -> Number -> Number
clamp lo hi x = max lo (min hi x)

move :: forall m. Number -> Number -> Moveable m -> Moveable m
move w h obj = obj { x = (w + obj.x + obj.dx) % w
                   , y = (h + obj.y + obj.dy) % h }

render :: forall s e. STRef s State -> Eff (st :: ST s, canvas :: Canvas | e ) Unit
render st = do
  state <- readSTRef st
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas
  setFillStyle "#000000" ctx
  fillPath ctx $ rect ctx { x: 0, y: 0, w: state.w, h: state.h }

  -- Draw the score
  save ctx
  setFillStyle "#ffffff" ctx
  setFont "16px Hyperspace" ctx
  fillText ctx (show state.score) 10 20
  restore ctx

  -- Draw the remaining ships
  forE 1 state.nships $ \i -> do
      let ship = (defaultShip 0 0) { x = 20 * i, y = 40 }
      renderShip ctx ship "#ffffff" false
      return unit

  case state.phase of
    Playing ship    -> renderShip ctx ship "#ffffff" (state.controls.thrust /= 0)

    Respawning _    -> renderShip ctx (defaultShip state.w state.h) "#555555" false

    Crashing ship i -> renderCrash ctx ship i

    GameOver        -> do let message = "Game Over"
                          save ctx
                          setFillStyle "#ffffff" ctx
                          setFont "40px Hyperspace" ctx
                          metrics <- measureText ctx message
                          fillText ctx "Game Over" (state.w / 2 - metrics.width / 2) (state.h / 2)
                          restore ctx
                          return unit

  foldM (renderAsteroid ctx) unit state.asteroids
  foldM (renderMissile ctx) unit state.missiles
  return unit

renderShip :: forall e. Context2D -> Ship -> String -> Boolean -> Eff ( canvas :: Canvas | e ) Unit
renderShip ctx ship color engines = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle color ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  lineTo ctx 0 8
  lineTo ctx 7 10
  lineTo ctx 0 (-10)
  stroke ctx

  when engines $ do
    moveTo ctx (-4) 11
    lineTo ctx 0 15
    lineTo ctx 4 11
    stroke ctx
    return unit

  restore ctx
  return unit

renderCrash :: forall e. Context2D -> Ship -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderCrash ctx ship i = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle "#ffffff" ctx

  save ctx
  translate { translateX: -i, translateY: -i } ctx
  rotate (i * pi / 60) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: -i } ctx
  rotate ((-i) * pi / 30) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: -i, translateY: i } ctx
  rotate ((-i) * pi / 20) ctx
  beginPath ctx
  moveTo ctx (-7) 10
  lineTo ctx 0 8
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: i } ctx
  rotate (i * pi / 15) ctx
  beginPath ctx
  moveTo ctx 0 8
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  restore ctx

  return unit

renderAsteroid :: forall e. Context2D -> Unit -> Asteroid -> Eff ( canvas :: Canvas | e ) Unit
renderAsteroid ctx _ asteroid = do
  save ctx

  setLineWidth 1 ctx
  translate { translateX: asteroid.x, translateY: asteroid.y } ctx
  setStrokeStyle "#ffffff" ctx
  beginPath ctx

  let n = length asteroid.path
      steps = map ((*) (2 * pi / n)) (1 .. n)
      theta = fromJust $ last steps
      off = fromJust $ last asteroid.path

  moveTo ctx (asteroid.r * off * cos theta) (asteroid.r * off * sin theta)

  for_ (zip asteroid.path steps) $ \(Tuple off theta) -> do
                                  let x = asteroid.r * off * cos theta
                                      y = asteroid.r * off * sin theta
                                  lineTo ctx x y

  stroke ctx

  restore ctx
  return unit

renderMissile :: forall e. Context2D -> Unit -> Missile -> Eff ( canvas :: Canvas | e ) Unit
renderMissile ctx _ missile = do
  save ctx
  setFillStyle "#ffffff" ctx
  fillPath ctx $ arc ctx { x: missile.x, y: missile.y, r: 2, start: 0, end: 2 * pi }
  restore ctx
  return unit


use effCanceler

use effCanceler

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, effCanceler, makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
          domContentLoaded = EventType "DOMContentLoaded"
      addEventListener domContentLoaded listener false et
      pure $ effCanceler (removeEventListener domContentLoaded listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
          domContentLoaded = EventType "DOMContentLoaded"
      addEventListener domContentLoaded listener false et
      pure $ Canceler \_ -> liftEff (removeEventListener domContentLoaded listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))


change syntax a bit using alias for (*>)

rationale here is that it’s useful to initially mimic D3 syntax in the DSL and develop some validating experiments with that and then experiment with finding a better syntax afterwards.

module Main where

import TaglessD3.Selection
import Control.Apply (applySecond)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, logShow)
import Prelude (Unit, ($))

infixl 4 applySecond as ..

myD3Structure :: D3Structure
myD3Structure = initD3S "Awn"

myD3Structure2 :: D3Structure
myD3Structure2 = initD3S "Bel"

d3Script2 :: ∀ m. (Selection m) => m Unit
d3Script2 = d3Select "quux"

d3Script' :: ∀ m. (Selection m) => m Unit
d3Script' = d3Select "foo"
         .. select "bar"
         .. selectAll "baz"

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  logShow $ run' d3Script' myD3Structure

module Main where

import Prelude (Unit, bind, pure, ($))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
import TaglessD3.Selection --(class Selection, D3Structure(..), FakeSelection(..), d3Select, run, run')

myD3Structure :: D3Structure
myD3Structure = initD3S "Awn"

myD3Structure2 :: D3Structure
myD3Structure2 = initD3S "Bel"

d3Script2 :: ∀ m. (Selection m) => m Unit
d3Script2 = d3Select "quux"

d3Script :: ∀ m. (Selection m) => m Unit
d3Script = do
    s  <- d3Select "foo"
    s2 <- select "bar"
    s3 <- selectAll "baz"
    s4 <- merge d3Script2 myD3Structure2
    pure s3

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  logShow $ run' d3Script myD3Structure


Add tooltip if expression can't be evaluated

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Ace (ace)
import Ace.Types (EAce())
import qualified Ace.Editor as Editor

import Data.Either
import Data.Maybe
import Data.Array ((..), length, deleteAt, (!!), drop)
import Data.Tuple
import Data.Traversable (zipWithA)
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

foreign import isEnterKey
  """
  function isEnterKey(event) {
    return event.which == 13;
  }
  """ :: J.JQueryEvent -> Boolean

type DOMEff = Eff (dom :: DOM, trace :: Trace, ace :: EAce)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue
  case parseExpr input of
    Left msg   -> showInfo "Expression" msg
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left msg  -> showInfo "Definitions" msg
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => [a] -> (a -> Number -> m b) -> m [b]
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: [Expr] -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. [a] -> Number -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Number -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = deleteAt i 1 es.history }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left err -> void $ J.setAttr "title" (show err) jq
      Right _  -> void $ J.addClass "clickable" jq *> J.setAttr "title" "" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    -- Left msg   -> liftEff $ showInfo "execution" msg
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Ace (ace)
import Ace.Types (EAce())
import qualified Ace.Editor as Editor

import Data.Either
import Data.Maybe
import Data.Array ((..), length, deleteAt, (!!), drop)
import Data.Tuple
import Data.Traversable (zipWithA)
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

foreign import isEnterKey
  """
  function isEnterKey(event) {
    return event.which == 13;
  }
  """ :: J.JQueryEvent -> Boolean

type DOMEff = Eff (dom :: DOM, trace :: Trace, ace :: EAce)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue
  case parseExpr input of
    Left msg   -> showInfo "Expression" msg
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left msg  -> showInfo "Definitions" msg
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => [a] -> (a -> Number -> m b) -> m [b]
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: [Expr] -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. [a] -> Number -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Number -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = deleteAt i 1 es.history }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left  _ -> return unit
      Right _ -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    -- Left msg   -> liftEff $ showInfo "execution" msg
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq