Added more laws to Enum

Added more laws to Enum

module Data.Enum
  ( Enum
  , Cardinality(..)
  , cardinality
  , firstEnum
  , fromEnum
  , lastEnum
  , pred
  , runCardinality
  , succ
  , toEnum
  , defaultSucc
  , defaultPred
  , defaultToEnum
  , defaultFromEnum
  ) where

  import Data.Maybe
  import Data.Either
  import Data.Tuple
  import Data.Char
  import Data.Maybe.Unsafe

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. DayOfWeek, etc.
  -- |
  -- | Laws:
  -- |   succ firstEnum >>= succ >>= succ ... succ [cardinality - 1 times] == lastEnum
  -- |   pred lastEnum  >>= pred >>= pred ... pred [cardinality - 1 times] == firstEnum
  -- |
  -- |   e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2
  -- |
  -- |   for all a > firstEnum: pred a >>= succ == Just a
  -- |   for all a < lastEnum:  succ a >>= pred == Just a
  -- |
  -- |   pred >=> succ >=> pred = pred
  -- |   succ >=> pred >=> succ = succ
  -- |
  -- |   toEnum (fromEnum a) = Just a
  -- |
  -- |   for all a > firstEnum: fromEnum <$> pred a = Just (fromEnum a - 1)
  -- |   for all a < lastEnum:  fromEnum <$> succ a = Just (fromEnum a + 1)

  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

    toEnum :: Number -> Maybe a

    fromEnum :: a -> Number

  -- | defaultSucc toEnum fromEnum = succ
  defaultSucc :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

  -- | defaultPred toEnum fromEnum = pred
  defaultPred :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultToEnum succ firstEnum = toEnum
  defaultToEnum :: forall a. (a -> Maybe a) -> a -> (Number -> Maybe a)
  defaultToEnum succ' firstEnum' n | n < 0 = Nothing
  defaultToEnum succ' firstEnum' 0         = Just firstEnum'
  defaultToEnum succ' firstEnum' n         = defaultToEnum succ' firstEnum' (n - 1) >>= succ'

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultFromEnum pred = fromEnum
  defaultFromEnum :: forall a. (a -> Maybe a) -> (a -> Number)
  defaultFromEnum pred' e = maybe 0 (\prd -> defaultFromEnum pred' prd + 1) (pred' e)

  instance enumChar :: Enum Char where
    cardinality = Cardinality (65535 + 1)

    firstEnum = fromCharCode 0

    lastEnum = fromCharCode 65535

    succ = defaultSucc charToEnum charFromEnum

    pred = defaultPred charToEnum charFromEnum

    toEnum = charToEnum

    fromEnum = charFromEnum

  -- To avoid a compiler bug - can't pass self-class functions, workaround: need to make a concrete function.
  charToEnum :: Number -> Maybe Char
  charToEnum n | n >= 0 && n <= 65535 = Just $ fromCharCode n
  charToEnum _ = Nothing

  charFromEnum :: Char -> Number
  charFromEnum = toCharCode

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

    toEnum = maybeToEnum cardinality

    fromEnum Nothing = 0
    fromEnum (Just e) = fromEnum e + 1

  maybeToEnum :: forall a. (Enum a) => Cardinality a -> Number -> Maybe (Maybe a)
  maybeToEnum carda n | n <= runCardinality (maybeCardinality carda) =
    if n == 0
    then Just $ Nothing
    else Just $ toEnum (n - 1)
  maybeToEnum _    _ = Nothing

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = booleanFirstEnum

    lastEnum = true

    succ = booleanSucc

    pred = booleanPred

    toEnum = defaultToEnum booleanSucc booleanFirstEnum

    fromEnum = defaultFromEnum booleanPred

  booleanFirstEnum :: Boolean
  booleanFirstEnum = false

  booleanSucc :: Boolean -> Maybe Boolean
  booleanSucc false = Just true
  booleanSucc _     = Nothing

  booleanPred :: Boolean -> Maybe Boolean
  booleanPred true  = Just false
  booleanPred _     = Nothing

  -- Until we get Int, floor and div in the prelude
  foreign import floor "function floor(n){ return Math.floor(n); }" :: Number -> Number
  div a b = floor (a / b)

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

    toEnum = tupleToEnum cardinality

    fromEnum = tupleFromEnum cardinality

  -- All of these are as a workaround for ScopedTypeVariables. (not yet supported in Purescript)
  tupleToEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Number -> Maybe (Tuple a b)
  tupleToEnum cardb n = Tuple <$> (toEnum (n `div` (runCardinality cardb))) <*> (toEnum (n % (runCardinality cardb)))

  tupleFromEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Tuple a b -> Number
  tupleFromEnum cardb (Tuple a b) = (fromEnum a) * runCardinality cardb + fromEnum b

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)

  instance enumEither :: (Enum a, Enum b) => Enum (Either a b) where
    cardinality = eitherCardinality cardinality cardinality

    firstEnum = Left firstEnum

    lastEnum = Right lastEnum

    succ (Left a) = maybe (Just $ Right firstEnum) (Just <<< Left) (succ a)
    succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)

    pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
    pred (Right b) = maybe (Just $ Left lastEnum) (Just <<< Right) (pred b)

    toEnum = eitherToEnum cardinality cardinality

    fromEnum = eitherFromEnum cardinality

  eitherToEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Number -> Maybe (Either a b)
  eitherToEnum carda cardb n =
        if n >= 0 && n < runCardinality carda
        then Left <$> toEnum n
        else if n >= (runCardinality carda) && n < runCardinality (eitherCardinality carda cardb)
             then Right <$> toEnum (n - runCardinality carda)
             else Nothing

  eitherFromEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> (Either a b -> Number)
  eitherFromEnum carda (Left a) = fromEnum a
  eitherFromEnum carda (Right b) = fromEnum b + runCardinality carda

  eitherCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Either a b)
  eitherCardinality l r = Cardinality $ (runCardinality l) + (runCardinality r)

module Data.Enum
  ( Enum
  , Cardinality(..)
  , cardinality
  , firstEnum
  , fromEnum
  , lastEnum
  , pred
  , runCardinality
  , succ
  , toEnum
  , defaultSucc
  , defaultPred
  , defaultToEnum
  , defaultFromEnum
  ) where

  import Data.Maybe
  import Data.Either
  import Data.Tuple
  import Data.Char
  import Data.Maybe.Unsafe

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. DayOfWeek, etc.
  -- |
  -- | Laws:
  -- |   succ firstEnum >>= succ >>= succ ... succ [cardinality times] == lastEnum
  -- |   pred lastEnum  >>= pred >>= pred ... pred [cardinality times] == firstEnum
  -- |
  -- |   Just $ e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2
  -- |
  -- |   for all a > firstEnum: pred a >>= succ == Just a
  -- |   for all a < lastEnum:  succ a >>= pred == Just a
  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

    toEnum :: Number -> Maybe a

    fromEnum :: a -> Number

  -- | defaultSucc toEnum fromEnum = succ
  defaultSucc :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

  -- | defaultPred toEnum fromEnum = pred
  defaultPred :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultToEnum succ firstEnum = toEnum
  defaultToEnum :: forall a. (a -> Maybe a) -> a -> (Number -> Maybe a)
  defaultToEnum succ' firstEnum' n | n < 0 = Nothing
  defaultToEnum succ' firstEnum' 0         = Just firstEnum'
  defaultToEnum succ' firstEnum' n         = defaultToEnum succ' firstEnum' (n - 1) >>= succ'

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultFromEnum pred = fromEnum
  defaultFromEnum :: forall a. (a -> Maybe a) -> (a -> Number)
  defaultFromEnum pred' e = maybe 0 (\prd -> defaultFromEnum pred' prd + 1) (pred' e)

  instance enumChar :: Enum Char where
    cardinality = Cardinality (65535 + 1)

    firstEnum = fromCharCode 0

    lastEnum = fromCharCode 65535

    succ = defaultSucc charToEnum charFromEnum

    pred = defaultPred charToEnum charFromEnum

    toEnum = charToEnum

    fromEnum = charFromEnum

  -- To avoid a compiler bug - can't pass self-class functions, workaround: need to make a concrete function.
  charToEnum :: Number -> Maybe Char
  charToEnum n | n >= 0 && n <= 65535 = Just $ fromCharCode n
  charToEnum _ = Nothing

  charFromEnum :: Char -> Number
  charFromEnum = toCharCode

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

    toEnum = maybeToEnum cardinality

    fromEnum Nothing = 0
    fromEnum (Just e) = fromEnum e + 1

  maybeToEnum :: forall a. (Enum a) => Cardinality a -> Number -> Maybe (Maybe a)
  maybeToEnum carda n | n <= runCardinality (maybeCardinality carda) =
    if n == 0
    then Just $ Nothing
    else Just $ toEnum (n - 1)
  maybeToEnum _    _ = Nothing

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = booleanFirstEnum

    lastEnum = true

    succ = booleanSucc

    pred = booleanPred

    toEnum = defaultToEnum booleanSucc booleanFirstEnum

    fromEnum = defaultFromEnum booleanPred

  booleanFirstEnum :: Boolean
  booleanFirstEnum = false

  booleanSucc :: Boolean -> Maybe Boolean
  booleanSucc false = Just true
  booleanSucc _     = Nothing

  booleanPred :: Boolean -> Maybe Boolean
  booleanPred true  = Just false
  booleanPred _     = Nothing

  -- Until we get Int, floor and div in the prelude
  foreign import floor "function floor(n){ return Math.floor(n); }" :: Number -> Number
  div a b = floor (a / b)

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

    toEnum = tupleToEnum cardinality

    fromEnum = tupleFromEnum cardinality

  -- All of these are as a workaround for ScopedTypeVariables. (not yet supported in Purescript)
  tupleToEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Number -> Maybe (Tuple a b)
  tupleToEnum cardb n = Tuple <$> (toEnum (n `div` (runCardinality cardb))) <*> (toEnum (n % (runCardinality cardb)))

  tupleFromEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Tuple a b -> Number
  tupleFromEnum cardb (Tuple a b) = (fromEnum a) * runCardinality cardb + fromEnum b

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)

  instance enumEither :: (Enum a, Enum b) => Enum (Either a b) where
    cardinality = eitherCardinality cardinality cardinality

    firstEnum = Left firstEnum

    lastEnum = Right lastEnum

    succ (Left a) = maybe (Just $ Right firstEnum) (Just <<< Left) (succ a)
    succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)

    pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
    pred (Right b) = maybe (Just $ Left lastEnum) (Just <<< Right) (pred b)

    toEnum = eitherToEnum cardinality cardinality

    fromEnum = eitherFromEnum cardinality

  eitherToEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Number -> Maybe (Either a b)
  eitherToEnum carda cardb n =
        if n >= 0 && n < runCardinality carda
        then Left <$> toEnum n
        else if n >= (runCardinality carda) && n < runCardinality (eitherCardinality carda cardb)
             then Right <$> toEnum (n - runCardinality carda)
             else Nothing

  eitherFromEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> (Either a b -> Number)
  eitherFromEnum carda (Left a) = fromEnum a
  eitherFromEnum carda (Right b) = fromEnum b + runCardinality carda

  eitherCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Either a b)
  eitherCardinality l r = Cardinality $ (runCardinality l) + (runCardinality r)


Remove Lazy instance

Remove Lazy instance

module Data.Lazy where

import qualified Control.Lazy as CL

foreign import data Lazy :: * -> *

foreign import defer
  "function defer(thunk) {\
  \    if (this instanceof defer) {\
  \      this.thunk = thunk;\
  \      return this;\
  \    } else {\
  \      return new defer(thunk);\
  \    }\
  \}\
  \defer.prototype.force = function () {\
  \    var value = this.thunk();\
  \    delete this.thunk;\
  \    this.force = function () {\
  \        return value;\
  \    };\
  \    return value;\
  \};" :: forall a. ({} -> a) -> Lazy a

foreign import force
  "function force(l) {\
  \  return l.force();\
  \}" :: forall a. Lazy a -> a

instance functorLazy :: Functor Lazy where
  (<$>) f l = defer $ \_ -> f (force l)

instance applyLazy :: Apply Lazy where
  (<*>) f x = defer $ \_ -> force f $ force x

instance applicativeLazy :: Applicative Lazy where
  pure a = defer $ \_ -> a

instance bindLazy :: Bind Lazy where
  (>>=) l f = defer $ \_ -> force <<< f <<< force $ l

instance monadLazy :: Monad Lazy

instance eqLazy :: (Eq a) => Eq (Lazy a) where
  (==) x y = (force x) == (force y)
  (/=) x y = not (x == y)

instance ordLazy :: (Ord a) => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

instance showLazy :: (Show a) => Show (Lazy a) where
  show x = "Lazy " ++ show (force x)

instance lazy1Lazy :: CL.Lazy1 Lazy where
  defer1 f = defer (\_ -> force (f unit))

module Data.Lazy where

import qualified Control.Lazy as CL

foreign import data Lazy :: * -> *

foreign import defer
  "function defer(thunk) {\
  \    if (this instanceof defer) {\
  \      this.thunk = thunk;\
  \      return this;\
  \    } else {\
  \      return new defer(thunk);\
  \    }\
  \}\
  \defer.prototype.force = function () {\
  \    var value = this.thunk();\
  \    delete this.thunk;\
  \    this.force = function () {\
  \        return value;\
  \    };\
  \    return value;\
  \};" :: forall a. ({} -> a) -> Lazy a

foreign import force
  "function force(l) {\
  \  return l.force();\
  \}" :: forall a. Lazy a -> a

instance functorLazy :: Functor Lazy where
  (<$>) f l = defer $ \_ -> f (force l)

instance applyLazy :: Apply Lazy where
  (<*>) f x = defer $ \_ -> force f $ force x

instance applicativeLazy :: Applicative Lazy where
  pure a = defer $ \_ -> a

instance bindLazy :: Bind Lazy where
  (>>=) l f = defer $ \_ -> force <<< f <<< force $ l

instance monadLazy :: Monad Lazy

instance eqLazy :: (Eq a) => Eq (Lazy a) where
  (==) x y = (force x) == (force y)
  (/=) x y = not (x == y)

instance ordLazy :: (Ord a) => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

instance showLazy :: (Show a) => Show (Lazy a) where
  show x = "Lazy " ++ show (force x)

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer (\_ -> force (f unit))

instance lazy1Lazy :: CL.Lazy1 Lazy where
  defer1 f = defer (\_ -> force (f unit))


Added initial main menu

Added initial main menu

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press space to start" "AAAAAA" 6 12
    return MainMenu

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress console MainMenu key | key == 32 = return initialState
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st@(Game state) = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 initialState {onKeyPress: onKeyPress, onUpdate: onUpdate}


Fix `Main.purs`

Fix `Main.purs`

module Main where

import AST (Expr, Atom(Name), Tree(Atom), TypeTree)
import Parser as Parser
import Evaluator as Eval
import Web as Web
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (empty)
import Data.Array (cons)
import Data.Traversable (for)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery as J

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM | eff) Unit
makeCE input selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container Nothing
  pure unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefs input defs selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env [] container Nothing

makeCEwithHistory :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithHistory input selector histSelector = do
  container <- J.select selector
  histContainer <- J.select histSelector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container (Just histContainer)

makeCEwithDefsAndHistory :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefsAndHistory  input defs selector histSelector = do
  container <- J.select selector
  histContainer <- J.select histSelector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env [] container (Just histContainer)

parseExpr :: String -> TypeTree
parseExpr input = case Parser.parseExpr input of
  Left err   -> (Atom Nothing (Name $ "parse error: " <> show err))
  Right expr -> expr

eval1 :: Eval.Env -> TypeTree -> TypeTree
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> Array TypeTree -> J.JQuery -> Maybe J.JQuery-> Web.Callback
makeCallback env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1
  case getType event of
    "click"     -> if evalFunc env expr /= expr
                   then showExprIn (hole (evalFunc env expr)) env (cons (hole expr) history) container histContainer
                   else pure unit
    "mouseover" -> if evalFunc env expr /= expr
                   then void $ J.addClass "highlight" jq
                   else pure unit
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

exprToJQuery :: forall eff. Web.Callback -> TypeTree -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery callback

showExprIn :: forall eff. TypeTree -> Eval.Env -> Array TypeTree -> J.JQuery -> Maybe J.JQuery-> Eff (dom :: DOM | eff) Unit
showExprIn expr env history container histContainer = do
  content <- exprToJQuery (makeCallback env history container histContainer) expr
  J.clear container
  J.append content container
  case histContainer of
    Nothing -> pure unit
    Just histContainer -> do
      J.clear histContainer
      for history $ \expr -> do
        histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) expr
        histDiv <- J.create "

"
        J.addClass "history-element" histDiv
        J.append histExpr histDiv
        J.append histDiv histContainer
      pure unit
  pure unit

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right defs -> Eval.defsToEnv defs

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" <>
  "and (False:xs) = False\n" <>
  "and []         = True\n" <>
  "\n" <>
  "or (False:xs) = or xs\n" <>
  "or (True:xs)  = True\n" <>
  "or []         = False\n" <>
  "\n" <>
  "all p = and . map p\n" <>
  "any p = or . map p\n" <>
  "\n" <>
  "head (x:xs) = x\n" <>
  "tail (x:xs) = xs\n" <>
  "\n" <>
  "take 0 xs     = []\n" <>
  "take n (x:xs) = x : take (n - 1) xs\n" <>
  "\n" <>
  "drop 0 xs     = xs\n" <>
  "drop n (x:xs) = drop (n - 1) xs\n" <>
  "\n" <>
  "elem e []     = False\n" <>
  "elem e (x:xs) = if e == x then True else elem e xs\n" <>
  "\n" <>
  "max a b = if a >= b then a else b\n" <>
  "min a b = if b >= a then a else b\n" <>
  "\n" <>
  "maximum (x:xs) = foldr max x xs\n" <>
  "minimum (x:xs) = foldr min x xs\n" <>
  "\n" <>
  "length []     = 0\n" <>
  "length (x:xs) = 1 + length xs\n" <>
  "\n" <>
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" <>
  "zip []      _     = []\n" <>
  "zip _       []    = []\n" <>
  "\n" <>
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
  "zipWith _ []     _      = []\n" <>
  "zipWith _ _      []     = []\n" <>
  "\n" <>
  "unzip []          = ([], [])\n" <>
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" <>
  "\n" <>
  "fst (x,_) = x\n" <>
  "snd (_,x) = x\n" <>
  "\n" <>
  "curry f a b = f (a, b)\n" <>
  "uncurry f (a, b) = f a b\n" <>
  "\n" <>
  "repeat x = x : repeat x\n" <>
  "\n" <>
  "replicate 0 _ = []\n" <>
  "replicate n x = x : replicate (n - 1) x\n" <>
  "\n" <>
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" <>
  "\n" <>
  "sum (x:xs) = x + sum xs\n" <>
  "sum [] = 0\n" <>
  "\n" <>
  "product (x:xs) = x * product xs\n" <>
  "product [] = 1\n" <>
  "\n" <>
  "reverse []     = []\n" <>
  "reverse (x:xs) = reverse xs ++ [x]\n" <>
  "\n" <>
  "concat = foldr (++) []\n" <>
  "\n" <>
  "map f []     = []\n" <>
  "map f (x:xs) = f x : map f xs\n" <>
  "\n" <>
  "not True  = False\n" <>
  "not False = True\n" <>
  "\n" <>
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" <>
  "filter p []     = []\n" <>
  "\n" <>
  "foldr f ini []     = ini\n" <>
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" <>
  "\n" <>
  "foldl f acc []     = acc\n" <>
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" <>
  "\n" <>
  "scanl f b []     = [b]\n" <>
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" <>
  "\n" <>
  "iterate f x = x : iterate f (f x)\n" <>
  "\n" <>
  "id x = x\n" <>
  "\n" <>
  "const x _ = x\n" <>
  "\n" <>
  "flip f x y = f y x\n" <>
  "\n" <>
  "even n = (n `mod` 2) == 0\n" <>
  "odd n = (n `mod` 2) == 1\n" <>
  "\n" <>
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

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

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> pure unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

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

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

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

--   liftEff $ pure unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   pure scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

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

-- 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
--   pure 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, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then pure unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then pure unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> pure unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- 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.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     pure unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree 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
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path -> do
--         pure unit
--         if checkForError path typeTree
--           then pure unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

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

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> pure unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

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

module Main where

import AST (Expr, Atom(Name), Tree(Atom))
import Parser as Parser
import Evaluator as Eval
import Web as Web
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (empty)
import Data.Array (cons)
import Data.Traversable (for)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery as J

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM | eff) Unit
makeCE input selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container Nothing
  pure unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefs input defs selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env [] container Nothing

makeCEwithHistory :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithHistory input selector histSelector = do
  container <- J.select selector
  histContainer <- J.select histSelector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container (Just histContainer)

makeCEwithDefsAndHistory :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefsAndHistory  input defs selector histSelector = do
  container <- J.select selector
  histContainer <- J.select histSelector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env [] container (Just histContainer)

parseExpr :: String -> Expr
parseExpr input = case Parser.parseExpr input of
  Left err   -> (Atom unit (Name $ "parse error: " <> show err))
  Right expr -> expr

eval1 :: Eval.Env -> Expr -> Expr
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> Array Expr -> J.JQuery -> Maybe J.JQuery-> Web.Callback
makeCallback env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1
  case getType event of
    "click"     -> if evalFunc env expr /= expr
                   then showExprIn (hole (evalFunc env expr)) env (cons (hole expr) history) container histContainer
                   else pure unit
    "mouseover" -> if evalFunc env expr /= expr
                   then void $ J.addClass "highlight" jq
                   else pure unit
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

exprToJQuery :: forall eff. Web.Callback -> Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery callback

showExprIn :: forall eff. Expr -> Eval.Env -> Array Expr -> J.JQuery -> Maybe J.JQuery-> Eff (dom :: DOM | eff) Unit
showExprIn expr env history container histContainer = do
  content <- exprToJQuery (makeCallback env history container histContainer) expr
  J.clear container
  J.append content container
  case histContainer of
    Nothing -> pure unit
    Just histContainer -> do
      J.clear histContainer
      for history $ \expr -> do
        histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) expr
        histDiv <- J.create "

"
        J.addClass "history-element" histDiv
        J.append histExpr histDiv
        J.append histDiv histContainer
      pure unit
  pure unit

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right defs -> Eval.defsToEnv defs

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" <>
  "and (False:xs) = False\n" <>
  "and []         = True\n" <>
  "\n" <>
  "or (False:xs) = or xs\n" <>
  "or (True:xs)  = True\n" <>
  "or []         = False\n" <>
  "\n" <>
  "all p = and . map p\n" <>
  "any p = or . map p\n" <>
  "\n" <>
  "head (x:xs) = x\n" <>
  "tail (x:xs) = xs\n" <>
  "\n" <>
  "take 0 xs     = []\n" <>
  "take n (x:xs) = x : take (n - 1) xs\n" <>
  "\n" <>
  "drop 0 xs     = xs\n" <>
  "drop n (x:xs) = drop (n - 1) xs\n" <>
  "\n" <>
  "elem e []     = False\n" <>
  "elem e (x:xs) = if e == x then True else elem e xs\n" <>
  "\n" <>
  "max a b = if a >= b then a else b\n" <>
  "min a b = if b >= a then a else b\n" <>
  "\n" <>
  "maximum (x:xs) = foldr max x xs\n" <>
  "minimum (x:xs) = foldr min x xs\n" <>
  "\n" <>
  "length []     = 0\n" <>
  "length (x:xs) = 1 + length xs\n" <>
  "\n" <>
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" <>
  "zip []      _     = []\n" <>
  "zip _       []    = []\n" <>
  "\n" <>
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
  "zipWith _ []     _      = []\n" <>
  "zipWith _ _      []     = []\n" <>
  "\n" <>
  "unzip []          = ([], [])\n" <>
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" <>
  "\n" <>
  "fst (x,_) = x\n" <>
  "snd (_,x) = x\n" <>
  "\n" <>
  "curry f a b = f (a, b)\n" <>
  "uncurry f (a, b) = f a b\n" <>
  "\n" <>
  "repeat x = x : repeat x\n" <>
  "\n" <>
  "replicate 0 _ = []\n" <>
  "replicate n x = x : replicate (n - 1) x\n" <>
  "\n" <>
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" <>
  "\n" <>
  "sum (x:xs) = x + sum xs\n" <>
  "sum [] = 0\n" <>
  "\n" <>
  "product (x:xs) = x * product xs\n" <>
  "product [] = 1\n" <>
  "\n" <>
  "reverse []     = []\n" <>
  "reverse (x:xs) = reverse xs ++ [x]\n" <>
  "\n" <>
  "concat = foldr (++) []\n" <>
  "\n" <>
  "map f []     = []\n" <>
  "map f (x:xs) = f x : map f xs\n" <>
  "\n" <>
  "not True  = False\n" <>
  "not False = True\n" <>
  "\n" <>
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" <>
  "filter p []     = []\n" <>
  "\n" <>
  "foldr f ini []     = ini\n" <>
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" <>
  "\n" <>
  "foldl f acc []     = acc\n" <>
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" <>
  "\n" <>
  "scanl f b []     = [b]\n" <>
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" <>
  "\n" <>
  "iterate f x = x : iterate f (f x)\n" <>
  "\n" <>
  "id x = x\n" <>
  "\n" <>
  "const x _ = x\n" <>
  "\n" <>
  "flip f x y = f y x\n" <>
  "\n" <>
  "even n = (n `mod` 2) == 0\n" <>
  "odd n = (n `mod` 2) == 1\n" <>
  "\n" <>
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

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

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> pure unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

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

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

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

--   liftEff $ pure unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   pure scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

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

-- 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
--   pure 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, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then pure unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then pure unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> pure unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- 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.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     pure unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree 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
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path -> do
--         pure unit
--         if checkForError path typeTree
--           then pure unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

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

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> pure unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

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


Refactored function to obtain a coordinate's index, not necessarily an index with a piece

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

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

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

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

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

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

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

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

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

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

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

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Fixed a bug where an exception was thrown using the UTC module.

Date.UTC doesn't return a valid JavaScript Date object, but rather
just the time in milliseconds since epoch. This meant that the
dateTime method was broken.

module Data.Date.UTC
  ( dateTime
  , date
  , year
  , month
  , dayOfMonth
  , dayOfWeek
  , hourOfDay
  , minuteOfHour
  , secondOfMinute
  , millisecondOfSecond
  ) where

import Data.Date
import Data.Enum (fromEnum, toEnum)
import Data.Function (Fn2(), runFn2, Fn7(), runFn7)
import Data.Int (Int())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.Time

-- | Attempts to create a `Date` from UTC date and time components. `Nothing`
-- | is returned if the resulting date is invalid.
dateTime :: Year -> Month -> DayOfMonth
         -> HourOfDay -> MinuteOfHour -> SecondOfMinute -> MillisecondOfSecond
         -> Maybe Date
dateTime y mo d h mi s ms =
  fromJSDate (runFn7 jsDateFromValues y (fromEnum mo) d h mi s ms)

-- | Attempts to create a `Date` from UTC date components. `Nothing` is
-- | returned if the resulting date is invalid.
date :: Year -> Month -> DayOfMonth -> Maybe Date
date y m d = dateTime y m d (HourOfDay zero) (MinuteOfHour zero) (SecondOfMinute zero) (MillisecondOfSecond zero)

-- | Gets the UTC year component for a date.
year :: Date -> Year
year d = runFn2 dateMethod "getUTCFullYear" d

-- | Gets the UTC month component for a date.
month :: Date -> Month
month d = fromJust (toEnum (runFn2 dateMethod "getUTCMonth" d))

-- | Gets the UTC day-of-month value for a date.
dayOfMonth :: Date -> DayOfMonth
dayOfMonth d = runFn2 dateMethod "getUTCDate" d

-- | Gets the UTC day-of-week value for a date.
dayOfWeek :: Date -> DayOfWeek
dayOfWeek d = fromJust (toEnum (runFn2 dateMethod "getUTCDay" d))

-- | Gets the UTC hour-of-day value for a date.
hourOfDay :: Date -> HourOfDay
hourOfDay d = runFn2 dateMethod "getUTCHours" d

-- | Gets the UTC minute-of-hour value for a date.
minuteOfHour :: Date -> MinuteOfHour
minuteOfHour d = runFn2 dateMethod "getUTCMinutes" d

-- | Get the UTC second-of-minute value for a date.
secondOfMinute :: Date -> SecondOfMinute
secondOfMinute d = runFn2 dateMethod "getUTCSeconds" d

-- | Get the UTC millisecond-of-second value for a date.
millisecondOfSecond :: Date -> MillisecondOfSecond
millisecondOfSecond d = runFn2 dateMethod "getUTCMilliseconds" d

foreign import dateMethod
  """
  function dateMethod(method, date) {
    return date[method]();
  }
  """ :: forall a. Fn2 String Date a

foreign import jsDateFromValues
  """
  function jsDateFromValues(y, mo, d, h, mi, s, ms) {
    return new Date(Date.UTC(y, mo, d, h, mi, s, ms));
  }
  """ :: Fn7 Year Number DayOfMonth HourOfDay MinuteOfHour SecondOfMinute MillisecondOfSecond JSDate

module Data.Date.UTC
  ( dateTime
  , date
  , year
  , month
  , dayOfMonth
  , dayOfWeek
  , hourOfDay
  , minuteOfHour
  , secondOfMinute
  , millisecondOfSecond
  ) where

import Data.Date
import Data.Enum (fromEnum, toEnum)
import Data.Function (Fn2(), runFn2, Fn7(), runFn7)
import Data.Int (Int())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.Time

-- | Attempts to create a `Date` from UTC date and time components. `Nothing`
-- | is returned if the resulting date is invalid.
dateTime :: Year -> Month -> DayOfMonth
         -> HourOfDay -> MinuteOfHour -> SecondOfMinute -> MillisecondOfSecond
         -> Maybe Date
dateTime y mo d h mi s ms =
  fromJSDate (runFn7 jsDateFromValues y (fromEnum mo) d h mi s ms)

-- | Attempts to create a `Date` from UTC date components. `Nothing` is
-- | returned if the resulting date is invalid.
date :: Year -> Month -> DayOfMonth -> Maybe Date
date y m d = dateTime y m d (HourOfDay zero) (MinuteOfHour zero) (SecondOfMinute zero) (MillisecondOfSecond zero)

-- | Gets the UTC year component for a date.
year :: Date -> Year
year d = runFn2 dateMethod "getUTCFullYear" d

-- | Gets the UTC month component for a date.
month :: Date -> Month
month d = fromJust (toEnum (runFn2 dateMethod "getUTCMonth" d))

-- | Gets the UTC day-of-month value for a date.
dayOfMonth :: Date -> DayOfMonth
dayOfMonth d = runFn2 dateMethod "getUTCDate" d

-- | Gets the UTC day-of-week value for a date.
dayOfWeek :: Date -> DayOfWeek
dayOfWeek d = fromJust (toEnum (runFn2 dateMethod "getUTCDay" d))

-- | Gets the UTC hour-of-day value for a date.
hourOfDay :: Date -> HourOfDay
hourOfDay d = runFn2 dateMethod "getUTCHours" d

-- | Gets the UTC minute-of-hour value for a date.
minuteOfHour :: Date -> MinuteOfHour
minuteOfHour d = runFn2 dateMethod "getUTCMinutes" d

-- | Get the UTC second-of-minute value for a date.
secondOfMinute :: Date -> SecondOfMinute
secondOfMinute d = runFn2 dateMethod "getUTCSeconds" d

-- | Get the UTC millisecond-of-second value for a date.
millisecondOfSecond :: Date -> MillisecondOfSecond
millisecondOfSecond d = runFn2 dateMethod "getUTCMilliseconds" d

foreign import dateMethod
  """
  function dateMethod(method, date) {
    return date[method]();
  }
  """ :: forall a. Fn2 String Date a

foreign import jsDateFromValues
  """
  function jsDateFromValues(y, mo, d, h, mi, s, ms) {
    return Date.UTC(y, mo, d, h, mi, s, ms);
  }
  """ :: Fn7 Year Number DayOfMonth HourOfDay MinuteOfHour SecondOfMinute MillisecondOfSecond JSDate


More examples from ch 4

More examples from ch 4

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, map, null)
import Data.Array.Unsafe (head, last, tail)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = filter (\xs -> product xs == n) $ do
  i <- 1 .. n
  j <- i .. n
  --return [i, j]
  [[i, j]]

main = do
  let array = (1..10)
  print $ size array
  print $ fact 10
  print $ fib 10
  print $ square array
  print $ positives (-5..5)
  print $ pairs 3
  print $ factors 10

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, map, null)
import Data.Array.Unsafe (head, last, tail)
import Debug.Trace

--length :: forall a. [a] -> Number
--length arr =
--  if null arr
--     then 0
--     else 1 + length (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
-- -- with conditionals
--isEven n =
--  if n % 2 == 0
--     then true
--     else false
-- with pattern matching and recursion
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

isPositive :: forall a. [Number] -> [Number]
isPositive arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

factors :: Number -> [[Number]]
factors n = filter (\pair -> product pair == n) (pairs n)

main = print $ countEven [1,2,3,4,5,6,7,8,9,10]


Add new/misisng parameters

Add new/misisng parameters

module PscIde.Server where

import Prelude
import Node.Buffer as Buffer
import Node.Path as Path
import Control.Alt ((<|>))
import Control.Monad.Aff (attempt, Aff, delay, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Parallel.Class (parallel)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Newtype (unwrap)
import Data.StrMap (StrMap)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (for)
import Global (readInt)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, StdIOBehaviour, Exit(Normally), onClose, onError, defaultSpawnOptions, spawn, defaultExecOptions, execFile, pipe)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Sync (readTextFile, unlink, writeTextFile)
import Node.Which (which')
import PscIde (NET, quit)

data ServerStartResult =
  Started ChildProcess
  | Closed
  | StartError String

type PscIdeServerArgs = {
  exe :: String,
  combinedExe :: Boolean,
  cwd :: Maybe String,
  stdio :: Array (Maybe StdIOBehaviour),
  source :: Array String, -- source globs
  port :: Maybe Int,
  directory :: Maybe String,
  outputDirectory :: Maybe String,
  watch :: Boolean,
  debug :: Boolean,
  polling :: Boolean,
  editorMode :: Boolean,
  logLevel :: Maybe LogLevel
}

data LogLevel = All | None | Debug | Perf
logParam :: LogLevel -> String
logParam = case _ of
  All -> "all"
  None -> "none"
  Debug -> "debug"
  Perf -> "perf"

defaultServerArgs :: PscIdeServerArgs
defaultServerArgs = {
  exe: "purs",
  -- TODO: Remove combinedExe when support for the non-combined executable can be removed
  combinedExe: true,
  cwd: Nothing,
  stdio: pipe,
  source: [],
  port: Nothing,
  directory: Nothing,
  outputDirectory: Nothing,
  watch: true,
  debug: false,
  polling: false,
  editorMode: false,
  logLevel: Nothing
}

-- | Start a psc-ide server instance
startServer ∷ forall eff.  PscIdeServerArgs → Aff (cp ∷ CHILD_PROCESS, avar ∷ AVAR | eff) ServerStartResult
startServer { stdio, exe, combinedExe, cwd, source, port, directory, outputDirectory, watch, debug, polling, editorMode, logLevel } = do
    cp <- liftEff (spawn exe (
      (if combinedExe then ["ide", "server"] else []) <>
      (maybe [] (\p -> ["-p", show p]) port) <>
      (maybe [] (\d -> ["-d", d]) directory) <>
      (maybe [] (\od -> ["--output-directory", od]) outputDirectory) <>
      (if watch then [] else ["--no-watch"]) <>
      (if debug then ["--debug"] else []) <>
      (if polling then ["--polling"] else []) <>
      (if editorMode then ["--editor-mode"] else []) <>
      (maybe [] (\l -> ["--log-level", logParam l]) logLevel) <>
      source
      ) defaultSpawnOptions { cwd = cwd, stdio = stdio })
    let handleErr = makeAff \_ succ -> do
                      onError cp (\_ -> succ $ StartError "psc-ide-server error")
                      onClose cp (\exit -> case exit of
                                     (Normally 0) -> succ Closed
                                     (Normally n) -> succ $ StartError $ "Error code returned: "<> show n
                                     _ -> succ $ StartError "Other close error")

    unwrap (parallel handleErr <|> parallel (delay (Milliseconds 100.0) $> Started cp))

-- | Construct path to the port file identifying the psc-ide-server port
portFilePath :: String -> String
portFilePath cwd = Path.concat [ cwd, ".psc-ide-port" ]

-- | Save a port to the port file
savePort :: forall eff. Int → String → Eff (fs :: FS, exception :: EXCEPTION | eff) Unit
savePort port cwd = writeTextFile UTF8 (portFilePath cwd) (show port)

-- | Delete the port file
deleteSavedPort :: forall eff. String → Eff (fs :: FS, exception :: EXCEPTION | eff) Unit
deleteSavedPort cwd = unlink (portFilePath cwd)

-- | Get the saved port for the given project directory (if present)
getSavedPort :: forall eff. String → Eff (fs :: FS | eff) (Maybe Int)
getSavedPort cwd = do
  text <- catchException (\_ -> pure Nothing) (Just <$> readTextFile UTF8 (portFilePath cwd))
  pure $ maybe Nothing (fromNumber <<< readInt 10) text

-- | Generate a fresh port (just now, randomly with no check or retry)
pickFreshPort :: forall eff. Eff (random :: RANDOM | eff) Int
pickFreshPort = randomInt 15000 16000

-- | Stop a psc-ide server.
stopServer :: forall eff. Int -> Aff (cp :: CHILD_PROCESS, net :: NET | eff) Unit
stopServer port = void $ quit port

data Executable = Executable String (Maybe String)

findBins :: forall eff. String -> Aff (fs :: FS, buffer :: BUFFER, cp :: CHILD_PROCESS | eff) (Array Executable)
findBins = findBins' { path: Nothing, pathExt: Nothing, env: Nothing }

findBins' :: forall eff. { path :: Maybe String, pathExt :: Maybe String, env :: Maybe (StrMap String) } -> String -> Aff (fs :: FS, buffer :: BUFFER, cp :: CHILD_PROCESS | eff) (Array Executable)
findBins' { path, pathExt, env } executable = do
  bins <- which' { path, pathExt } executable <|> pure []
  for bins \bin -> Executable bin <$> either (const Nothing) Just <$> attempt (getVersion bin)

  where
  getVersion :: forall eff'. String -> Aff (buffer :: BUFFER, cp :: CHILD_PROCESS | eff') String
  getVersion bin = makeAff $ \err succ ->
    execFile bin ["--version"] (defaultExecOptions { env = env }) \({error, stdout}) -> do
      maybe (Buffer.readString UTF8 0 100 stdout >>= succ) err error

module PscIde.Server where

import Prelude
import Node.Buffer as Buffer
import Node.Path as Path
import Control.Alt ((<|>))
import Control.Monad.Aff (attempt, Aff, delay, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Parallel.Class (parallel)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Newtype (unwrap)
import Data.StrMap (StrMap)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (for)
import Global (readInt)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, StdIOBehaviour, Exit(Normally), onClose, onError, defaultSpawnOptions, spawn, defaultExecOptions, execFile, pipe)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Sync (readTextFile, unlink, writeTextFile)
import Node.Which (which')
import PscIde (NET, quit)

data ServerStartResult =
  Started ChildProcess
  | Closed
  | StartError String

type PscIdeServerArgs = {
  exe :: String,
  combinedExe :: Boolean,
  cwd :: Maybe String,
  stdio :: Array (Maybe StdIOBehaviour),
  source :: Array String, -- source globs
  port :: Maybe Int,
  directory :: Maybe String,
  outputDirectory :: Maybe String,
  watch :: Boolean,
  debug :: Boolean
}

defaultServerArgs :: PscIdeServerArgs
defaultServerArgs = {
  exe: "purs",
  -- TODO: Remove combinedExe when support for the non-combined executable can be removed
  combinedExe: true,
  cwd: Nothing,
  stdio: pipe,
  source: [],
  port: Nothing,
  directory: Nothing,
  outputDirectory: Nothing,
  watch: true,
  debug: false
}

-- | Start a psc-ide server instance
startServer ∷ forall eff.  PscIdeServerArgs → Aff (cp ∷ CHILD_PROCESS, avar ∷ AVAR | eff) ServerStartResult
startServer { stdio, exe, combinedExe, cwd, source, port, directory, outputDirectory, watch, debug } = do
    cp <- liftEff (spawn exe (
      (if combinedExe then ["ide", "server"] else []) <>
      (maybe [] (\p -> ["-p", show p]) port) <>
      (maybe [] (\d -> ["-d", d]) directory) <>
      (maybe [] (\od -> ["--output-directory", od]) outputDirectory) <>
      (if watch then [] else ["--no-watch"]) <>
      (if debug then ["--debug"] else []) <>
      source
      ) defaultSpawnOptions { cwd = cwd, stdio = stdio })
    let handleErr = makeAff \_ succ -> do
                      onError cp (\_ -> succ $ StartError "psc-ide-server error")
                      onClose cp (\exit -> case exit of
                                     (Normally 0) -> succ Closed
                                     (Normally n) -> succ $ StartError $ "Error code returned: "<> show n
                                     _ -> succ $ StartError "Other close error")

    unwrap (parallel handleErr <|> parallel (delay (Milliseconds 100.0) $> Started cp))

-- | Construct path to the port file identifying the psc-ide-server port
portFilePath :: String -> String
portFilePath cwd = Path.concat [ cwd, ".psc-ide-port" ]

-- | Save a port to the port file
savePort :: forall eff. Int → String → Eff (fs :: FS, exception :: EXCEPTION | eff) Unit
savePort port cwd = writeTextFile UTF8 (portFilePath cwd) (show port)

-- | Delete the port file
deleteSavedPort :: forall eff. String → Eff (fs :: FS, exception :: EXCEPTION | eff) Unit
deleteSavedPort cwd = unlink (portFilePath cwd)

-- | Get the saved port for the given project directory (if present)
getSavedPort :: forall eff. String → Eff (fs :: FS | eff) (Maybe Int)
getSavedPort cwd = do
  text <- catchException (\_ -> pure Nothing) (Just <$> readTextFile UTF8 (portFilePath cwd))
  pure $ maybe Nothing (fromNumber <<< readInt 10) text

-- | Generate a fresh port (just now, randomly with no check or retry)
pickFreshPort :: forall eff. Eff (random :: RANDOM | eff) Int
pickFreshPort = randomInt 15000 16000

-- | Stop a psc-ide server.
stopServer :: forall eff. Int -> Aff (cp :: CHILD_PROCESS, net :: NET | eff) Unit
stopServer port = void $ quit port

data Executable = Executable String (Maybe String)

findBins :: forall eff. String -> Aff (fs :: FS, buffer :: BUFFER, cp :: CHILD_PROCESS | eff) (Array Executable)
findBins = findBins' { path: Nothing, pathExt: Nothing, env: Nothing }

findBins' :: forall eff. { path :: Maybe String, pathExt :: Maybe String, env :: Maybe (StrMap String) } -> String -> Aff (fs :: FS, buffer :: BUFFER, cp :: CHILD_PROCESS | eff) (Array Executable)
findBins' { path, pathExt, env } executable = do
  bins <- which' { path, pathExt } executable <|> pure []
  for bins \bin -> Executable bin <$> either (const Nothing) Just <$> attempt (getVersion bin)

  where
  getVersion :: forall eff'. String -> Aff (buffer :: BUFFER, cp :: CHILD_PROCESS | eff') String
  getVersion bin = makeAff $ \err succ ->
    execFile bin ["--version"] (defaultExecOptions { env = env }) \({error, stdout}) -> do
      maybe (Buffer.readString UTF8 0 100 stdout >>= succ) err error