Fix: block evaluation of not type correct expr

module Main where

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.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, print)
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 DOM (DOM)
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, buildEmptyTypeTree, 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 return 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' = buildEmptyTypeTree 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 _ -> return 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 $ return 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
  return 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
  return 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
  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, 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   -> return unit
      Just path ->
        case evalPath1 env path expr of
          Left err -> displayEvalError err jq
          Right _  -> if checkForError path typeTree
            then return 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 return unit
    else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
  _         -> return 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
    return 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   -> return unit
      Just path -> do
        return unit
        if checkForError path typeTree
          then return 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    -> return unit
    Right expr' -> do
        let eitherTyp = typeTreeProgramnEnv typEnv expr'
        let typ'' = either (\_ -> buildEmptyTypeTree 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 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.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, print)
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 DOM (DOM)
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, buildEmptyTypeTree, 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 return 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' = buildEmptyTypeTree 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 _ -> return 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
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return 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
  return 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
  return 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
  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, 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   -> return unit
      Just path ->
        case evalPath1 env path expr of
          Left err -> displayEvalError err jq
          Right _  -> if checkForError path typeTree
            then return 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 return unit
    else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
  _         -> return 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
    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
    mpath <- getPath jq
    case mpath of
      Nothing   -> return unit
      Just path -> 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    -> return unit
    Right expr' -> do
        let eitherTyp = typeTreeProgramnEnv typEnv expr'
        let typ'' = either (\_ -> buildEmptyTypeTree 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


Fix typo

Fix typo

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Foreign (renderForeignError)
import Data.List (List(..), (:))
import Data.List.NonEmpty as NonEmptyList
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, currentDir, dir, dir', file, parseRelFile, printPath, runDirName, sandbox, (<.>), (</>))
import Data.String as S
import Data.Traversable (traverse)
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Debug.Trace (trace)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.CodeGen (moduleToSwift)
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> String -> String -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) ffis codegens = do
  for_ trie \(Trie.Path path) ->
    case Array.unsnoc path of
      Just { init, last } -> do
        log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
        let
          enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
          decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
        log $ prettyPrint decl <> "\n"
      Nothing -> pure unit
  log ffis
  log codegens

type State =
  { moduleNamePaths :: Array Trie.Path
  , ffis :: String
  , codegens :: String
  }

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) State
toPaths filenames = foldr acc (pure { moduleNamePaths: [], ffis: "", codegens: "" }) filtered
-- toPaths filenames = foldr acc (pure { moduleNamePaths: [], ffis: "", codegens: "" }) $ trace (show filtered) \_ -> filtered
  where
    filtered :: Array FilePath
    filtered = flip Array.filter filenames \filename ->
      maybe false (S.singleton >>> (_ /= ".")) $ S.charAt 0 filename

    acc
      :: String
      -> Aff (Effects eff) State
      -> Aff (Effects eff) State
    acc filename state = do
      { moduleNamePaths, ffis, codegens } <- state
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        when
          :: Boolean
          -> Aff (Effects eff) State
          -> Aff (Effects eff) State
        when true m = m
        when false _ = state

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) State
          -> Aff (Effects eff) State
        whenM mb m = do
          b <- mb
          when b m

      stat <- stat $ printPath moduleDir

      when (isDirectory stat) do
        let filepath = printPath $ moduleDir </> file "corefn.json"
        -- trace ("------") \_ ->
        -- trace ("filepath" <> show filepath) \_ ->

        whenM (exists filepath) do
          -- moduleNamePaths' <- moduleNamePaths
          coreFn <- readTextFile UTF8 filepath
          let
            psModule = runExcept $ moduleFromJSON coreFn

            -- Convert `ForeignError` to `String` to unify with Swift errors
            psModule' = lmap (map renderForeignError) psModule

            -- TODO: move `NonEmptyList` inside of `moduleToSwift`, to track
            -- multiple errors at once
            moduleToSwift' = moduleToSwift >>> lmap NonEmptyList.singleton

            swiftModule = map _.module psModule' >>= moduleToSwift'
            modules = { psModule: _, swiftModule: _ } <$> psModule' <*> swiftModule
          case modules of
            Left e ->
              -- trace ("Left: " <> show e) \_->
              state
            Right { psModule: ps, swiftModule: swift } -> do
              let
                { moduleForeign, moduleName, modulePath } = unwrap ps.module
                codegen = prettyPrint swift

                -- decls = moduleToSwift $ trace ("module_: " <> show module_) \_ -> module_
                -- codegen = prettyPrint $ trace ("decls: " <> show decls) \_ -> decls
                -- codegen = trace ("decls: " <> show decls) \_ -> ""

                hasForeign = not Array.null moduleForeign
                ffiPath = if hasForeign then map (_ <.> "swift") (sandbox currentDir =<< parseRelFile (unwrap modulePath)) else Nothing
                -- foo = trace ("ffiPath: " <> show (map printPath ffiPath)) \_ -> unit

              ffi <- traverse (printPath >>> readTextFile UTF8) ffiPath
              -- let bar = trace ("ffi: " <> show ffi) \_ -> unit

              let
                moduleNamePath = Trie.Path $ map unwrap $ unwrap moduleName
                foreignNamePaths = guard hasForeign [moduleNamePath <> Trie.Path ["_Foreign"]]
                namePaths = [moduleNamePath] <> foreignNamePaths

              pure $
                { moduleNamePaths: namePaths <> moduleNamePaths
                , ffis: fromMaybe "" ffi <> "\n" <> ffis
                , codegens: codegen <> "\n" <> codegens
                -- , codegens: (trace ("codegen: " <> codegen) \_ -> codegen) <> "\n" <> codegens
                }

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  { moduleNamePaths, ffis, codegens } <- toPaths files
  let trie = fromPaths moduleNamePaths
  liftEff $ dryRun trie ffis codegens

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Foreign (renderForeignError)
import Data.List (List(..), (:))
import Data.List.NonEmpty as NonEmptyList
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, currentDir, dir, dir', file, parseRelFile, printPath, runDirName, sandbox, (<.>), (</>))
import Data.String as S
import Data.Traversable (traverse)
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Debug.Trace (trace)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.CodeGen (moduleToSwift)
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> String -> String -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) ffis codegens = do
  for_ trie \(Trie.Path path) ->
    case Array.unsnoc path of
      Just { init, last } -> do
        log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
        let
          enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
          decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
        log $ prettyPrint decl <> "\n"
      Nothing -> pure unit
  log ffis
  log codegens

type State =
  { moduleNamePaths :: Array Trie.Path
  , ffis :: String
  , codegens :: String
  }

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) State
-- toPaths filenames = foldr acc (pure { moduleNamePaths: [], ffis: "", codegens: "" }) filtered
toPaths filenames = foldr acc (pure { moduleNamePaths: [], ffis: "", codegens: "" }) $ trace (show filtered) \_ -> filtered
  where
    filtered :: Array FilePath
    filtered = flip Array.filter filenames \filename ->
      maybe false (S.singleton >>> (_ /= ".")) $ S.charAt 0 filename

    acc
      :: String
      -> Aff (Effects eff) State
      -> Aff (Effects eff) State
    acc filename state = do
      { moduleNamePaths, ffis, codegens } <- state
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        when
          :: Boolean
          -> Aff (Effects eff) State
          -> Aff (Effects eff) State
        when true m = m
        when false _ = state

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) State
          -> Aff (Effects eff) State
        whenM mb m = do
          b <- mb
          when b m

      stat <- stat $ printPath moduleDir

      when (isDirectory stat) do
        let filepath = printPath $ moduleDir </> file "corefn.json"
        trace ("------") \_ ->
        trace ("filepath" <> show filepath) \_ ->

        whenM (exists filepath) do
          -- moduleNamePaths' <- moduleNamePaths
          coreFn <- readTextFile UTF8 filepath
          let
            psModule = runExcept $ moduleFromJSON coreFn

            -- Convert `ForeignError` to `String` to unify with Swift errors
            psModule' = lmap (map renderForeignError) psModule

            -- TODO: move `NonEmptyList` inside pf `moduleToSwift`, to track
            -- multiple errors at once
            moduleToSwift' = moduleToSwift >>> lmap NonEmptyList.singleton

            swiftModule = map _.module psModule' >>= moduleToSwift'
            modules = { psModule: _, swiftModule: _ } <$> psModule' <*> swiftModule
          case modules of
            Left e ->
              -- trace ("Left: " <> show e) \_->
              state
            Right { psModule: ps, swiftModule: swift } -> do
              let
                { moduleForeign, moduleName, modulePath } = unwrap ps.module
                codegen = prettyPrint swift

                -- decls = moduleToSwift $ trace ("module_: " <> show module_) \_ -> module_
                -- codegen = prettyPrint $ trace ("decls: " <> show decls) \_ -> decls
                -- codegen = trace ("decls: " <> show decls) \_ -> ""

                hasForeign = not Array.null moduleForeign
                ffiPath = if hasForeign then map (_ <.> "swift") (sandbox currentDir =<< parseRelFile (unwrap modulePath)) else Nothing
                -- foo = trace ("ffiPath: " <> show (map printPath ffiPath)) \_ -> unit

              ffi <- traverse (printPath >>> readTextFile UTF8) ffiPath
              -- let bar = trace ("ffi: " <> show ffi) \_ -> unit

              let
                moduleNamePath = Trie.Path $ map unwrap $ unwrap moduleName
                foreignNamePaths = guard hasForeign [moduleNamePath <> Trie.Path ["_Foreign"]]
                namePaths = [moduleNamePath] <> foreignNamePaths

              pure $
                { moduleNamePaths: namePaths <> moduleNamePaths
                , ffis: fromMaybe "" ffi <> "\n" <> ffis
                , codegens: codegen <> "\n" <> codegens
                -- , codegens: (trace ("codegen: " <> codegen) \_ -> codegen) <> "\n" <> codegens
                }

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  { moduleNamePaths, ffis, codegens } <- toPaths files
  let trie = fromPaths moduleNamePaths
  liftEff $ dryRun trie ffis codegens


Scoring algorithm

Scoring algorithm

module App.AI where

import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import Data.Tuple as Tuple
import App.Board (Board, Player, PitRef)
import App.FixedMatrix72 (Ref(..), Row(..))
import Data.Array (filter, zipWith)
import Data.Foldable (maximum)
import Data.Maybe (Maybe)
import Data.Tuple (Tuple(..))
import Prelude (class Eq, class Ord, class Show, compare, eq, not, show, ($), (&&), (-), (<$>), (<<<), (<>), (==), (>))

newtype Selection = Selection (Tuple PitRef Int)

instance eqSelection :: Eq Selection where
  eq (Selection (Tuple r1 c1)) (Selection (Tuple r2 c2)) =
    eq c1 c2

instance ordSelection :: Ord Selection where
  compare (Selection (Tuple _ c1)) (Selection (Tuple _ c2)) = compare c1 c2

instance showSelection :: Show Selection where
  show (Selection (Tuple r1 c1)) =
    show "Selection: " <> show r1 <> " c=" <> show c1

selection :: PitRef -> Int -> Selection
selection ref = Selection <<< Tuple ref

suggest :: Player -> Board -> Maybe Selection
suggest player board = bestRef
  where bestRef = maximum $ zipWith selection refs (effectiveScore player <$> moves)
        moves = simulateMove player board <$> refs
        refs = filter validPit $ Board.refs player
        validPit r = Board.hasSeeds r board && not Board.isBlocked r board

simulateMove :: Player -> Board -> PitRef -> Board
simulateMove player board ref = Tuple.snd finalState
  where finalState = Turn.applyTurns (Turn.unfoldTurns state) state
        state = Tuple hand board
        hand = Hand.init player ref

effectiveScore :: Player -> Board -> Int
effectiveScore player board = playerStore - opponentStore
  where playerStore = Board.getStore player board
        opponentStore = Board.getStore (Board.opponentOf player) board

module App.AI where

import App.Board as Board
import App.Hand as Hand
import App.Turn as Turn
import Data.Tuple as Tuple
import App.Board (Board, Player, PitRef)
import App.FixedMatrix72 (Ref(..), Row(..))
import Data.Array (filter, zipWith)
import Data.Foldable (maximum)
import Data.Maybe (Maybe)
import Data.Tuple (Tuple(..))
import Prelude (class Eq, class Ord, class Show, compare, eq, not, show, ($), (&&), (<$>), (<<<), (<>), (==), (>))

newtype Selection = Selection (Tuple PitRef Int)

instance eqSelection :: Eq Selection where
  eq (Selection (Tuple r1 c1)) (Selection (Tuple r2 c2)) =
    eq c1 c2

instance ordSelection :: Ord Selection where
  compare (Selection (Tuple _ c1)) (Selection (Tuple _ c2)) = compare c1 c2

instance showSelection :: Show Selection where
  show (Selection (Tuple r1 c1)) =
    show "Selection: " <> show r1 <> " c=" <> show c1

selection :: PitRef -> Int -> Selection
selection ref = Selection <<< Tuple ref

suggest :: Player -> Board -> Maybe Selection
suggest player board = bestRef
  where bestRef = maximum $ zipWith selection refs (Board.getStore player <$> moves)
        moves = simulateMove player board <$> refs
        refs = filter validPit $ Board.refs player
        validPit r = Board.hasSeeds r board && not Board.isBlocked r board

simulateMove :: Player -> Board -> PitRef -> Board
simulateMove player board ref = Tuple.snd finalState
  where finalState = Turn.applyTurns (Turn.unfoldTurns state) state
        state = Tuple hand board
        hand = Hand.init player ref


Clean up type synonyms in Types

Clean up type synonyms in Types

module Types where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.Foldable
import Data.Function
import Data.Map (Map())
import Data.Map as Map
import Data.Either (Either())
import Data.Either as E
import Data.Tuple
import Data.String hiding (singleton, uncons)
import Data.Array (singleton)
import Data.Generic
import Graphics.Canvas
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import DOM.Timer
import Data.Lens
import Data.Lens.Getter ((^.))
import Data.Lens.Setter (over)
import Data.Lens.Types (LensP())
import DOM (DOM())
import Math (floor, pi, pow)

import GenericMap
import Utils
import NodeWebSocket as WS
import WebSocket as BWS

-- newtype wrapper is just for instances. We have to duplicate the type synonym
-- because of psc bug #1443
type Game =
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Int
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

newtype WrappedGame = WrappedGame
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Int
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

derive instance genericWrappedGame :: Generic WrappedGame

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

data PlayerId = P1 | P2 | P3 | P4

-- | For use in UIs, instead of the Show instance.
displayPlayerId :: PlayerId -> String
displayPlayerId x =
  case x of
    P1 -> "P1"
    P2 -> "P2"
    P3 -> "P3"
    P4 -> "P4"

derive instance genericPlayerId :: Generic PlayerId

allPlayerIds :: Array PlayerId
allPlayerIds = [P1, P2, P3, P4]

playerIdToInt :: PlayerId -> Int
playerIdToInt p =
  case p of
    P1 -> 1
    P2 -> 2
    P3 -> 3
    P4 -> 4

intToPlayerId :: Int -> Maybe PlayerId
intToPlayerId x =
  case x of
    1 -> Just P1
    2 -> Just P2
    3 -> Just P3
    4 -> Just P4
    _ -> Nothing

instance showPlayerId :: Show PlayerId where
  show = gShow

instance eqPlayerId :: Eq PlayerId where
  eq = gEq

instance ordPlayerId :: Ord PlayerId where
  compare = gCompare

type ItemId = Int

-- psc bug #1443
type LevelMap =
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

newtype WrappedLevelMap = WrappedLevelMap
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

unwrapLevelMap :: WrappedLevelMap -> LevelMap
unwrapLevelMap (WrappedLevelMap m) = m

derive instance genericLevelMap :: Generic WrappedLevelMap

data Block = Wall | Empty

derive instance genericBlock :: Generic Block

instance showBlock :: Show Block where
  show = gShow

-- A fixed size two-dimensional array of blocks.
type BlockTile = Array (Array Block)

data Tile
  = Intersection
  | TeeJunctionUp
  | TeeJunctionRight
  | TeeJunctionDown
  | TeeJunctionLeft
  | CornerUpRight
  | CornerRightDown
  | CornerDownLeft
  | CornerLeftUp
  | StraightHorizontal
  | StraightVertical
  | Inaccessible

derive instance genericTile :: Generic Tile

instance showTile :: Show Tile where
  show = gShow

isWall :: Block -> Boolean
isWall Wall = true
isWall _ = false

showRecord :: String -> Array String -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.::) :: forall a. (Show a) => String -> a -> String
(.::) name value = name <> ": " <> show value

failJsonParse :: forall a b. (Show a) => a -> String -> Either String b
failJsonParse value typ =
  E.Left $ "failed to parse " <> show value <> " as " <> typ <> "."

newtype Position = Position {x :: Number, y :: Number}

derive instance genericPosition :: Generic Position

instance showPosition :: Show Position where
  show = gShow

instance eqPosition :: Eq Position where
  eq = gEq

addPos :: Position -> Position -> Position
addPos (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

scalePos :: Number -> Position -> Position
scalePos s (Position p) = Position {x: s * p.x, y: s * p.y}

quadrance :: Position -> Position -> Number
quadrance (Position p) (Position q) =
  ((p.x - q.x) `pow` 2.0) + ((p.y - q.y) `pow` 2.0)

data GameObject = GOPlayer Player | GOItem Item

derive instance genericGameObject :: Generic GameObject

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      , score :: Int
      , nomIndex :: Int
      , respawnCounter :: Maybe Int
      }

derive instance genericPlayer :: Generic Player

nomIndexMax = 10

mkPlayer :: Position -> Player
mkPlayer pos =
  Player { position: pos
         , direction: Nothing
         , intendedDirection: Nothing
         , score: 0
         , nomIndex: nomIndexMax / 2
         , respawnCounter: Nothing
         }

players :: LensP Game (Map PlayerId Player)
players = lens (\o -> runGenericMap o.players) (\o x -> o { players = mkGenericMap x })

items :: LensP Game (Map ItemId Item)
items = lens (\o -> runGenericMap o.items) (\o x -> o { items = mkGenericMap x })

pPosition :: LensP Player Position
pPosition = lens
  (\(Player p) -> p.position)
  (\(Player p) pos -> Player $ p { position = pos })

pDirection :: LensP Player (Maybe Direction)
pDirection = lens
  (\(Player p) -> p.direction)
  (\(Player p) dir -> Player $ p { direction = dir })

pIntendedDirection :: LensP Player (Maybe Direction)
pIntendedDirection = lens
  (\(Player p) -> p.intendedDirection)
  (\(Player p) dir -> Player $ p { intendedDirection = dir })

pScore :: LensP Player Int
pScore = lens
  (\(Player p) -> p.score)
  (\(Player p) s -> Player $ p { score = s })

pNomIndex :: LensP Player Int
pNomIndex = lens
  (\(Player p) -> p.nomIndex)
  (\(Player p) s -> Player $ p { nomIndex = s })

pRespawnCounter :: LensP Player (Maybe Int)
pRespawnCounter = lens
  (\(Player p) -> p.respawnCounter)
  (\(Player p) s -> Player $ p { respawnCounter = s })

eachPlayer' :: forall f. (Applicative f) =>
  Game -> (PlayerId -> Player -> f Unit) -> f Unit
eachPlayer' game action =
  for_ (Map.toList $ game ^. players) $ uncurry action

eachPlayer :: (PlayerId -> Player -> GameUpdateM Unit) -> GameUpdateM Unit
eachPlayer action = do
  game <- getGame
  eachPlayer' game action

newtype Item
  = Item
     { position :: Position
     , itemType :: ItemType
     }

derive instance genericItem :: Generic Item

instance showItem :: Show Item where
  show = gShow

iType :: LensP Item ItemType
iType = lens
  (\(Item x) -> x.itemType)
  (\(Item x) typ -> Item $ x { itemType = typ })

iPosition :: LensP Item Position
iPosition = lens
  (\(Item x) -> x.position)
  (\(Item x) pos -> Item $ x { position = pos })

pX :: LensP Position Number
pX = lens
  (\(Position p) -> p.x)
  (\(Position p) x -> Position $ p { x = x })

pY :: LensP Position Number
pY = lens
  (\(Position p) -> p.y)
  (\(Position p) y -> Position $ p { y = y })

eachItem' :: forall f. (Applicative f) =>
  Game -> (Item -> f Unit) -> f Unit
eachItem' game action =
  for_ (game ^. items) action

data Direction = Up | Down | Left | Right

derive instance genericDirection :: Generic Direction

instance showDirection :: Show Direction where
  show = gShow

data ItemType = LittleDot | BigDot | Cherry

derive instance genericItemType :: Generic ItemType

instance showItemType :: Show ItemType where
  show = gShow

instance eqItemType :: Eq ItemType where
  eq = gEq

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0.0, y: -1.0}
dirToPos Left  = Position {x: -1.0, y:  0.0}
dirToPos Right = Position {x:  1.0, y:  0.0}
dirToPos Down  = Position {x:  0.0, y:  1.0}

directionToRadians :: Direction -> Number
directionToRadians d =
  case d of
    Right -> 0.0
    Down -> pi / 2.0
    Left -> pi
    Up -> 3.0 * pi / 2.0

opposite d =
  case d of
    Up -> Down
    Down -> Up
    Right -> Left
    Left -> Right

type Input = Map PlayerId (Maybe Direction)

data PlayerUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position
  | ChangedScore Int
  | ChangedNomIndex Int
  | ChangedRespawnCounter (Maybe Int)
  | PlayerLeft

derive instance genericPlayerUpdate :: Generic PlayerUpdate

instance showPlayerUpdate :: Show PlayerUpdate where
  show = gShow

data ItemUpdate
  = Eaten

derive instance genericItemUpdate :: Generic ItemUpdate

instance showItemUpdate :: Show ItemUpdate where
  show = gShow

data GameEndReason
  = Completed
  | TooManyPlayersDisconnected

derive instance genericGameEndReason :: Generic GameEndReason

instance showGameEndReason :: Show GameEndReason where
  show = gShow

data Rampage
  = Rampaging PlayerId Int
  | Cooldown Int

derive instance genericRampage :: Generic Rampage

data GameUpdate
  = GUPU PlayerId PlayerUpdate
  | GUIU ItemId ItemUpdate
  | ChangedCountdown (Maybe Int)
  | GameEnded GameEndReason
  | ChangedRampage (Maybe Rampage)

derive instance genericGameUpdate :: Generic GameUpdate

data ReadyState
  = Ready
  | NotReady

invertReadyState :: ReadyState -> ReadyState
invertReadyState Ready = NotReady
invertReadyState NotReady = Ready

derive instance genericReadyState :: Generic ReadyState

instance eqReadyState :: Eq ReadyState where
  eq = gEq

instance ordReadyState :: Ord ReadyState where
  compare = gCompare

instance showReadyState :: Show ReadyState where
  show = gShow

-- Sent by the server during the waiting stage, ie, after initial connection
-- but before the game starts
data WaitingUpdate
  = GameStarting WrappedGame
  | NewReadyStates (GenericMap PlayerId ReadyState)

derive instance genericWaitingUpdate :: Generic WaitingUpdate

type GameUpdateM a = WriterT (Array GameUpdate) (State WrappedGame) a

innerGame :: LensP WrappedGame Game
innerGame = lens (\(WrappedGame g) -> g) (const WrappedGame)

tellGameUpdate :: GameUpdate -> GameUpdateM Unit
tellGameUpdate = tell <<< singleton

modifyGame :: (Game -> Game) -> GameUpdateM Unit
modifyGame = modify <<< over innerGame

getGame :: GameUpdateM Game
getGame = gets (\x -> x ^. innerGame)

runGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple a (Tuple Game (Array GameUpdate))
runGameUpdateM game action =
  let a0 = runWriterT action
      a1 = runState a0 (WrappedGame game)
      rearrange (Tuple (Tuple x gus) (WrappedGame g))
        = Tuple x (Tuple g gus)

  in  rearrange a1

execGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple Game (Array GameUpdate)
execGameUpdateM game action = snd $ runGameUpdateM game action

input_ = lens (\s -> s.input) (\s x -> s { input = x })
game_ = lens (\s -> s.game) (\s x -> s { game = x })

data GameState
  = WaitingForPlayers GameStateWaitingForPlayers
  | InProgress        GameStateInProgress

type GameStateWaitingForPlayers = Map PlayerId ReadyState
type GameStateInProgress = { game :: Game, input :: Input }

data ServerOutgoingMessage
  = SOWaiting WaitingUpdate
  | SOInProgress (Array GameUpdate)

derive instance genericServerOutgoingMessage :: Generic ServerOutgoingMessage

asWaitingMessageO :: ServerOutgoingMessage -> Maybe WaitingUpdate
asWaitingMessageO (SOWaiting x) = Just x
asWaitingMessageO _ = Nothing

asInProgressMessageO :: ServerOutgoingMessage -> Maybe (Array GameUpdate)
asInProgressMessageO (SOInProgress x) = Just x
asInProgressMessageO _ = Nothing

data ServerIncomingMessage
  = SIToggleReadyState
  | SIInProgress Direction

derive instance genericServerIncomingMessage :: Generic ServerIncomingMessage

asWaitingMessage :: ServerIncomingMessage -> Maybe Unit
asWaitingMessage (SIToggleReadyState) = Just unit
asWaitingMessage _ = Nothing

asInProgressMessage :: ServerIncomingMessage -> Maybe Direction
asInProgressMessage (SIInProgress d) = Just d
asInProgressMessage _ = Nothing

matchMessage :: forall m a b. (Monad m) =>
  (a -> Maybe b) -> a -> (b -> m Unit) -> m Unit
matchMessage f msg action =
  maybe (return unit) action (f msg)

data ClientState
  = CWaitingForPlayers ClientStateWaiting
  | CInProgress        ClientStateInProgress

type ClientStateWaiting
  = { prevGame          :: Maybe Game
    , backgroundCleared :: Boolean
    , cachedHtml        :: String
    , readyStates       :: Map PlayerId ReadyState
    }

type ClientStateInProgress
  = { game :: Game
    , prevGame :: Game
    , redrawMap :: Boolean
    , cachedHtml :: String
    }

type RenderingContext =
  { foreground :: Context2D
  , background :: Context2D
  }

redrawMap = lens
  (\s -> s.redrawMap)
  (\s x -> s { redrawMap = x })

backgroundCleared = lens
  (\s -> s.backgroundCleared)
  (\s x -> s { backgroundCleared = x })

readyStates = lens
  (\s -> s.readyStates)
  (\s x -> s { readyStates = x })

cachedHtml = lens
  (\s -> s.cachedHtml)
  (\s x -> s { cachedHtml = x })

module Types where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.Foldable
import Data.Function
import Data.Map (Map())
import Data.Map as Map
import Data.Either (Either())
import Data.Either as E
import Data.Tuple
import Data.String hiding (singleton, uncons)
import Data.Array (singleton)
import Data.Generic
import Graphics.Canvas
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import DOM.Timer
import Data.Lens
import Data.Lens.Getter ((^.))
import Data.Lens.Setter (over)
import Data.Lens.Types (LensP())
import DOM (DOM())
import Math (floor, pi, pow)

import GenericMap
import Utils
import NodeWebSocket as WS
import WebSocket as BWS

-- newtype wrapper is just for instances. We have to duplicate the type synonym
-- because of psc bug #1443
type Game =
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Int
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

newtype WrappedGame = WrappedGame
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Int
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

derive instance genericWrappedGame :: Generic WrappedGame

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

data PlayerId = P1 | P2 | P3 | P4

-- | For use in UIs, instead of the Show instance.
displayPlayerId :: PlayerId -> String
displayPlayerId x =
  case x of
    P1 -> "P1"
    P2 -> "P2"
    P3 -> "P3"
    P4 -> "P4"

derive instance genericPlayerId :: Generic PlayerId

allPlayerIds :: Array PlayerId
allPlayerIds = [P1, P2, P3, P4]

playerIdToInt :: PlayerId -> Int
playerIdToInt p =
  case p of
    P1 -> 1
    P2 -> 2
    P3 -> 3
    P4 -> 4

intToPlayerId :: Int -> Maybe PlayerId
intToPlayerId x =
  case x of
    1 -> Just P1
    2 -> Just P2
    3 -> Just P3
    4 -> Just P4
    _ -> Nothing

instance showPlayerId :: Show PlayerId where
  show = gShow

instance eqPlayerId :: Eq PlayerId where
  eq = gEq

instance ordPlayerId :: Ord PlayerId where
  compare = gCompare

type ItemId = Int

-- psc bug #1443
type LevelMap =
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

newtype WrappedLevelMap = WrappedLevelMap
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

unwrapLevelMap :: WrappedLevelMap -> LevelMap
unwrapLevelMap (WrappedLevelMap m) = m

derive instance genericLevelMap :: Generic WrappedLevelMap

data Block = Wall | Empty

derive instance genericBlock :: Generic Block

instance showBlock :: Show Block where
  show = gShow

-- A fixed size two-dimensional array of blocks.
type BlockTile = Array (Array Block)

data Tile
  = Intersection
  | TeeJunctionUp
  | TeeJunctionRight
  | TeeJunctionDown
  | TeeJunctionLeft
  | CornerUpRight
  | CornerRightDown
  | CornerDownLeft
  | CornerLeftUp
  | StraightHorizontal
  | StraightVertical
  | Inaccessible

derive instance genericTile :: Generic Tile

instance showTile :: Show Tile where
  show = gShow

isWall :: Block -> Boolean
isWall Wall = true
isWall _ = false

showRecord :: String -> Array String -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.::) :: forall a. (Show a) => String -> a -> String
(.::) name value = name <> ": " <> show value

failJsonParse :: forall a b. (Show a) => a -> String -> Either String b
failJsonParse value typ =
  E.Left $ "failed to parse " <> show value <> " as " <> typ <> "."

newtype Position = Position {x :: Number, y :: Number}

derive instance genericPosition :: Generic Position

instance showPosition :: Show Position where
  show = gShow

instance eqPosition :: Eq Position where
  eq = gEq

addPos :: Position -> Position -> Position
addPos (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

scalePos :: Number -> Position -> Position
scalePos s (Position p) = Position {x: s * p.x, y: s * p.y}

quadrance :: Position -> Position -> Number
quadrance (Position p) (Position q) =
  ((p.x - q.x) `pow` 2.0) + ((p.y - q.y) `pow` 2.0)

data GameObject = GOPlayer Player | GOItem Item

derive instance genericGameObject :: Generic GameObject

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      , score :: Int
      , nomIndex :: Int
      , respawnCounter :: Maybe Int
      }

derive instance genericPlayer :: Generic Player

nomIndexMax = 10

mkPlayer :: Position -> Player
mkPlayer pos =
  Player { position: pos
         , direction: Nothing
         , intendedDirection: Nothing
         , score: 0
         , nomIndex: nomIndexMax / 2
         , respawnCounter: Nothing
         }

players :: LensP Game (Map PlayerId Player)
players = lens (\o -> runGenericMap o.players) (\o x -> o { players = mkGenericMap x })

items :: LensP Game (Map ItemId Item)
items = lens (\o -> runGenericMap o.items) (\o x -> o { items = mkGenericMap x })

pPosition :: LensP Player Position
pPosition = lens
  (\(Player p) -> p.position)
  (\(Player p) pos -> Player $ p { position = pos })

pDirection :: LensP Player (Maybe Direction)
pDirection = lens
  (\(Player p) -> p.direction)
  (\(Player p) dir -> Player $ p { direction = dir })

pIntendedDirection :: LensP Player (Maybe Direction)
pIntendedDirection = lens
  (\(Player p) -> p.intendedDirection)
  (\(Player p) dir -> Player $ p { intendedDirection = dir })

pScore :: LensP Player Int
pScore = lens
  (\(Player p) -> p.score)
  (\(Player p) s -> Player $ p { score = s })

pNomIndex :: LensP Player Int
pNomIndex = lens
  (\(Player p) -> p.nomIndex)
  (\(Player p) s -> Player $ p { nomIndex = s })

pRespawnCounter :: LensP Player (Maybe Int)
pRespawnCounter = lens
  (\(Player p) -> p.respawnCounter)
  (\(Player p) s -> Player $ p { respawnCounter = s })

eachPlayer' :: forall f. (Applicative f) =>
  Game -> (PlayerId -> Player -> f Unit) -> f Unit
eachPlayer' game action =
  for_ (Map.toList $ game ^. players) $ uncurry action

eachPlayer :: (PlayerId -> Player -> GameUpdateM Unit) -> GameUpdateM Unit
eachPlayer action = do
  game <- getGame
  eachPlayer' game action

newtype Item
  = Item
     { position :: Position
     , itemType :: ItemType
     }

derive instance genericItem :: Generic Item

instance showItem :: Show Item where
  show = gShow

iType :: LensP Item ItemType
iType = lens
  (\(Item x) -> x.itemType)
  (\(Item x) typ -> Item $ x { itemType = typ })

iPosition :: LensP Item Position
iPosition = lens
  (\(Item x) -> x.position)
  (\(Item x) pos -> Item $ x { position = pos })

pX :: LensP Position Number
pX = lens
  (\(Position p) -> p.x)
  (\(Position p) x -> Position $ p { x = x })

pY :: LensP Position Number
pY = lens
  (\(Position p) -> p.y)
  (\(Position p) y -> Position $ p { y = y })

eachItem' :: forall f. (Applicative f) =>
  Game -> (Item -> f Unit) -> f Unit
eachItem' game action =
  for_ (game ^. items) action

data Direction = Up | Down | Left | Right

derive instance genericDirection :: Generic Direction

instance showDirection :: Show Direction where
  show = gShow

data ItemType = LittleDot | BigDot | Cherry

derive instance genericItemType :: Generic ItemType

instance showItemType :: Show ItemType where
  show = gShow

instance eqItemType :: Eq ItemType where
  eq = gEq

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0.0, y: -1.0}
dirToPos Left  = Position {x: -1.0, y:  0.0}
dirToPos Right = Position {x:  1.0, y:  0.0}
dirToPos Down  = Position {x:  0.0, y:  1.0}

directionToRadians :: Direction -> Number
directionToRadians d =
  case d of
    Right -> 0.0
    Down -> pi / 2.0
    Left -> pi
    Up -> 3.0 * pi / 2.0

opposite d =
  case d of
    Up -> Down
    Down -> Up
    Right -> Left
    Left -> Right

type Input = Map PlayerId (Maybe Direction)

data PlayerUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position
  | ChangedScore Int
  | ChangedNomIndex Int
  | ChangedRespawnCounter (Maybe Int)
  | PlayerLeft

derive instance genericPlayerUpdate :: Generic PlayerUpdate

instance showPlayerUpdate :: Show PlayerUpdate where
  show = gShow

data ItemUpdate
  = Eaten

derive instance genericItemUpdate :: Generic ItemUpdate

instance showItemUpdate :: Show ItemUpdate where
  show = gShow

data GameEndReason
  = Completed
  | TooManyPlayersDisconnected

derive instance genericGameEndReason :: Generic GameEndReason

instance showGameEndReason :: Show GameEndReason where
  show = gShow

data Rampage
  = Rampaging PlayerId Int
  | Cooldown Int

derive instance genericRampage :: Generic Rampage

data GameUpdate
  = GUPU PlayerId PlayerUpdate
  | GUIU ItemId ItemUpdate
  | ChangedCountdown (Maybe Int)
  | GameEnded GameEndReason
  | ChangedRampage (Maybe Rampage)

derive instance genericGameUpdate :: Generic GameUpdate

data ReadyState
  = Ready
  | NotReady

invertReadyState :: ReadyState -> ReadyState
invertReadyState Ready = NotReady
invertReadyState NotReady = Ready

derive instance genericReadyState :: Generic ReadyState

instance eqReadyState :: Eq ReadyState where
  eq = gEq

instance ordReadyState :: Ord ReadyState where
  compare = gCompare

instance showReadyState :: Show ReadyState where
  show = gShow

-- Sent by the server during the waiting stage, ie, after initial connection
-- but before the game starts
data WaitingUpdate
  = GameStarting WrappedGame
  | NewReadyStates (GenericMap PlayerId ReadyState)

derive instance genericWaitingUpdate :: Generic WaitingUpdate

type GameUpdateM a = WriterT (Array GameUpdate) (State WrappedGame) a

-- these are just here to shorten declarations that are required because of
-- types that psc is not able to infer
-- TODO: clean this up?
type GameUpdateState = WrappedGame
type GameUpdateModifier = GameUpdateState -> GameUpdateState

innerGame :: LensP WrappedGame Game
innerGame = lens (\(WrappedGame g) -> g) (const WrappedGame)

tellGameUpdate :: GameUpdate -> GameUpdateM Unit
tellGameUpdate = tell <<< singleton

modifyGame :: (Game -> Game) -> GameUpdateM Unit
modifyGame = modify <<< f
  where
  f :: (Game -> Game) -> GameUpdateModifier
  f = over innerGame

getGame :: GameUpdateM Game
getGame = gets f
  where
  f :: GameUpdateState -> Game
  f x = x ^. innerGame

runGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple a (Tuple Game (Array GameUpdate))
runGameUpdateM game action =
  let a0 = runWriterT action
      a1 = runState a0 (WrappedGame game)
      rearrange (Tuple (Tuple x gus) (WrappedGame g))
        = Tuple x (Tuple g gus)

  in  rearrange a1

execGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple Game (Array GameUpdate)
execGameUpdateM game action = snd $ runGameUpdateM game action

input_ = lens (\s -> s.input) (\s x -> s { input = x })
game_ = lens (\s -> s.game) (\s x -> s { game = x })

data GameState
  = WaitingForPlayers GameStateWaitingForPlayers
  | InProgress        GameStateInProgress

type GameStateWaitingForPlayers = Map PlayerId ReadyState
type GameStateInProgress = { game :: Game, input :: Input }

data ServerOutgoingMessage
  = SOWaiting WaitingUpdate
  | SOInProgress (Array GameUpdate)

derive instance genericServerOutgoingMessage :: Generic ServerOutgoingMessage

asWaitingMessageO :: ServerOutgoingMessage -> Maybe WaitingUpdate
asWaitingMessageO (SOWaiting x) = Just x
asWaitingMessageO _ = Nothing

asInProgressMessageO :: ServerOutgoingMessage -> Maybe (Array GameUpdate)
asInProgressMessageO (SOInProgress x) = Just x
asInProgressMessageO _ = Nothing

data ServerIncomingMessage
  = SIToggleReadyState
  | SIInProgress Direction

derive instance genericServerIncomingMessage :: Generic ServerIncomingMessage

asWaitingMessage :: ServerIncomingMessage -> Maybe Unit
asWaitingMessage (SIToggleReadyState) = Just unit
asWaitingMessage _ = Nothing

asInProgressMessage :: ServerIncomingMessage -> Maybe Direction
asInProgressMessage (SIInProgress d) = Just d
asInProgressMessage _ = Nothing

matchMessage :: forall m a b. (Monad m) =>
  (a -> Maybe b) -> a -> (b -> m Unit) -> m Unit
matchMessage f msg action =
  maybe (return unit) action (f msg)

data ClientState
  = CWaitingForPlayers ClientStateWaiting
  | CInProgress        ClientStateInProgress

type ClientStateWaiting
  = { prevGame          :: Maybe Game
    , backgroundCleared :: Boolean
    , cachedHtml        :: String
    , readyStates       :: Map PlayerId ReadyState
    }

type ClientStateInProgress
  = { game :: Game
    , prevGame :: Game
    , redrawMap :: Boolean
    , cachedHtml :: String
    }

type RenderingContext =
  { foreground :: Context2D
  , background :: Context2D
  }

redrawMap = lens
  (\s -> s.redrawMap)
  (\s x -> s { redrawMap = x })

backgroundCleared = lens
  (\s -> s.backgroundCleared)
  (\s x -> s { backgroundCleared = x })

readyStates = lens
  (\s -> s.readyStates)
  (\s x -> s { readyStates = x })

cachedHtml = lens
  (\s -> s.cachedHtml)
  (\s x -> s { cachedHtml = x })


Uncomment all tests

Uncomment all tests

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GeneratorSpec (generatorSpec)
import Test.Spec.SolverSpec (solverSpec)

main = run [consoleReporter] do
  scannerSpec
  usageParserSpec
  descParserSpec
  solverSpec
  generatorSpec

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GeneratorSpec (generatorSpec)
import Test.Spec.SolverSpec (solverSpec)

main = run [consoleReporter] do
  -- scannerSpec
  -- usageParserSpec
  -- descParserSpec
  solverSpec
  -- generatorSpec