index will be handed through the cycle showExprIn -> buildDivTreeFromExpr -> makeCallBack -> showExprIn -> ...

module Main where

import AST as AST
import Parser as Parser
import Evaluator as Eval
import Web as Web
import TypeChecker as TypeChecker
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 Data.Tuple (Tuple (..))

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 , console :: CONSOLE| eff) Unit
makeCE input selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \(Tuple expr nextIdx) -> do
    let env = preludeEnv
    showExprIn expr nextIdx env [] container Nothing
    pure unit

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

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

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

-- | Try to parse the given expression and report parser errors.
parseExpr :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe (Tuple AST.TypeTree Int))
parseExpr input = case Parser.parseExpr input of
  Left error -> do
    showError "Parser" (show error)
    pure Nothing
  Right (Tuple expr nextIdx)-> pure $ Just (Tuple expr idx)

eval1 :: Int -> Eval.Env -> AST.TypeTree -> Either String (Tuple AST.TypeTree Int)
eval1 nextIdx env expr = case Eval.runEvalM (Eval.eval1 env expr) nextIdx of
  Left err             -> Left $ show err
  Right exprAndNextIdx -> Right exprAndNextIdx

eval1' :: Int -> Eval.Env -> AST.TypeTree -> Tuple AST.TypeTree Int
eval1' nextIdx env expr = case eval1 env expr of
  Left _      -> Tuple expr nextIdx
  Right expr' -> exprAndNextIdx

makeCallback :: Int
             -> Eval.Env
             -> Array AST.TypeTree
             -> J.JQuery
             -> Maybe J.JQuery
             -> Web.Callback
makeCallback nextIdx env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval nextIdx else eval1' nextIdx
      evaluated = evalFunc env expr -- :: Tuple TypeTree Index
  case getType event of
    "click"     -> if fst evaluated /= expr
                   then showExprIn (hole (evalFunc env expr)) (snd evaluated) env (cons (hole expr) history) container histContainer
                   else pure unit
    "mouseover" -> do
                     log $ show expr
                     case eval1 nextIdx env expr of
                       Right (Tuple expr' _) -> do -- index can be ignored here (I guess...)
                         log $ show expr'
                         J.addClass "highlight" jq
                       Left err   -> log err
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

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

-- | Clear the contents of info div.
clearInfo :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
clearInfo = void $ J.select "#info" >>= J.clear

-- | Create an info div and display an error inside.
showError :: forall eff. String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
showError origin msg = do
  info <- do
    paragraph <- J.create "

"
    J.addClass "info" paragraph
    J.setText ("Error in " <> origin <> " => " <> msg) paragraph
    pure paragraph
  clearInfo
  infoDiv <- J.select "#info"
  J.append info infoDiv

-- | Execute the given function if the given maybe (wrapped inside an effect) is a `Just x` value
-- | using `x` as the argument. If the maybe is `Nothing` don't do anything.
doWithJust :: forall a eff. Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe a)
         -> (a -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)
         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
doWithJust mMaybe f = do
  mValue <- mMaybe
  case mValue of
    Nothing -> pure unit
    Just x  -> f x

-- | Given an evaluation environment, try to infer the types inside of it.
buildTypeEnvironment :: Partial => Eval.Env -> Maybe TypeChecker.TypeEnv
buildTypeEnvironment env =
  let defs = Eval.envToDefs env
  in case TypeChecker.tryInferEnvironment defs of
    Left error -> Nothing
    Right typedEnv -> Just typedEnv

-- | Type check an expression using a given typed environment.
-- | Construct a div tree from the given typed expression.
typeCheckExpression :: forall eff. Partial => TypeChecker.TypeEnv -> AST.TypeTree
                 -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe AST.TypeTree)
typeCheckExpression typedEnv expr = do
  case TypeChecker.runInferWith typedEnv false (TypeChecker.inferExpr expr) of
    Left typeError -> do
      showError "Expression" (AST.prettyPrintTypeError typeError)
      pure Nothing
    Right typedExpr -> do
      pure $ Just typedExpr

-- | Construct a div tree from the given typed expression.
buildDivTreeFromExpression :: forall eff. AST.TypeTree
                           -> Int
                           -> Eval.Env
                           -> Array AST.TypeTree
                           -> J.JQuery
                           -> Maybe J.JQuery
                           -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
buildDivTreeFromExpression typedExpr nextIdx env history container histContainer = do
    content <- exprToJQuery (makeCallback nextIdx env history container histContainer) typedExpr
    J.clear container
    J.append content container
    case histContainer of
      Nothing -> pure unit
      Just histContainer -> do
        J.clear histContainer
        for history $ \typedExpr -> do
          histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) typedExpr
          histDiv <- J.create "

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

-- | Show the given expression inside a given environment after the types of the environment as
-- | well as the expression have been inferred.
showExprIn :: forall eff. AST.TypeTree
           -> Int
           -> Eval.Env
           -> Array AST.TypeTree
           -> J.JQuery
           -> Maybe J.JQuery
           -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
showExprIn expr nextIdx env history container histContainer = do
  -- Try to infer the types of the environment.
  -- doWithJust (buildTypeEnvironment expr env) \typedEnv -> do
    -- Try to infer the type of the given expression.
    -- doWithJust (typeCheckExpression preludeTyped expr) \typedExpr ->
      -- buildDivTreeFromExpression typedExpr env history container histContainer
    buildDivTreeFromExpression expr nextIdx env history container histContainer

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

preludeTyped :: Partial => TypeChecker.TypeEnv
preludeTyped = case buildTypeEnvironment preludeEnv of
  Just env -> env
  Nothing -> TypeChecker.emptyTypeEnv

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "data Maybe a = Nothing | Just a\n" <>
  "data List a = Nil | Cons a (List a)\n" <>
  "data IList a = INil | a :: (IList a)\n" <>
  "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 as AST
import Parser as Parser
import Evaluator as Eval
import Web as Web
import TypeChecker as TypeChecker
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 Data.Tuple (Tuple (..))

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 , console :: CONSOLE| eff) Unit
makeCE input selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \(Tuple expr nextIdx) -> do
    let env = preludeEnv
    showExprIn expr env [] container Nothing
    pure unit

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

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

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

-- | Try to parse the given expression and report parser errors.
parseExpr :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe (Tuple AST.TypeTree Int))
parseExpr input = case Parser.parseExpr input of
  Left error -> do
    showError "Parser" (show error)
    pure Nothing
  Right (Tuple expr nextIdx)-> pure $ Just (Tuple expr idx)

eval1 :: Eval.Env -> AST.TypeTree -> Either String AST.TypeTree
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left err    -> Left $ show err
  Right expr' -> Right expr'

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

makeCallback :: Eval.Env -> Array AST.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" -> do
                     log $ show expr
                     case eval1 env expr of
                       Right expr' -> do
                         log $ show expr'
                         J.addClass "highlight" jq
                       Left err   -> log err
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

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

-- | Clear the contents of info div.
clearInfo :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
clearInfo = void $ J.select "#info" >>= J.clear

-- | Create an info div and display an error inside.
showError :: forall eff. String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
showError origin msg = do
  info <- do
    paragraph <- J.create "

"
    J.addClass "info" paragraph
    J.setText ("Error in " <> origin <> " => " <> msg) paragraph
    pure paragraph
  clearInfo
  infoDiv <- J.select "#info"
  J.append info infoDiv

-- | Execute the given function if the given maybe (wrapped inside an effect) is a `Just x` value
-- | using `x` as the argument. If the maybe is `Nothing` don't do anything.
doWithJust :: forall a eff. Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe a)
         -> (a -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)
         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
doWithJust mMaybe f = do
  mValue <- mMaybe
  case mValue of
    Nothing -> pure unit
    Just x  -> f x

-- | Given an evaluation environment, try to infer the types inside of it.
buildTypeEnvironment :: Partial => Eval.Env -> Maybe TypeChecker.TypeEnv
buildTypeEnvironment env =
  let defs = Eval.envToDefs env
  in case TypeChecker.tryInferEnvironment defs of
    Left error -> Nothing
    Right typedEnv -> Just typedEnv

-- | Type check an expression using a given typed environment.
-- | Construct a div tree from the given typed expression.
typeCheckExpression :: forall eff. Partial => TypeChecker.TypeEnv -> AST.TypeTree
                 -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe AST.TypeTree)
typeCheckExpression typedEnv expr = do
  case TypeChecker.runInferWith typedEnv false (TypeChecker.inferExpr expr) of
    Left typeError -> do
      showError "Expression" (AST.prettyPrintTypeError typeError)
      pure Nothing
    Right typedExpr -> do
      pure $ Just typedExpr

-- | Construct a div tree from the given typed expression.
buildDivTreeFromExpression :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree
                           -> J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
buildDivTreeFromExpression typedExpr env history container histContainer = do
    content <- exprToJQuery (makeCallback env history container histContainer) typedExpr
    J.clear container
    J.append content container
    case histContainer of
      Nothing -> pure unit
      Just histContainer -> do
        J.clear histContainer
        for history $ \typedExpr -> do
          histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) typedExpr
          histDiv <- J.create "

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

-- | Show the given expression inside a given environment after the types of the environment as
-- | well as the expression have been inferred.
showExprIn :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree -> J.JQuery
           -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
showExprIn expr env history container histContainer = do
  -- Try to infer the types of the environment.
  -- doWithJust (buildTypeEnvironment expr env) \typedEnv -> do
    -- Try to infer the type of the given expression.
    -- doWithJust (typeCheckExpression preludeTyped expr) \typedExpr ->
      -- buildDivTreeFromExpression typedExpr env history container histContainer
    buildDivTreeFromExpression expr env history container histContainer

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

preludeTyped :: Partial => TypeChecker.TypeEnv
preludeTyped = case buildTypeEnvironment preludeEnv of
  Just env -> env
  Nothing -> TypeChecker.emptyTypeEnv

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "data Maybe a = Nothing | Just a\n" <>
  "data List a = Nil | Cons a (List a)\n" <>
  "data IList a = INil | a :: (IList a)\n" <>
  "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


Add functions for changing any aspect of an HalogenM action

Fixes #437.

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Fork (class MonadFork)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)

import Data.Bifunctor (lmap)
import Data.Coyoneda (Coyoneda, coyoneda, hoistCoyoneda)
import Data.Foreign (Foreign)
import Data.List as L
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Tuple (Tuple)

import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.InputF (RefLabel)

-- | The Halogen component algebra
data HalogenF s (f :: Type -> Type) g p o m a
  = State (s -> Tuple a s)
  | Subscribe (ES.EventSource f m) a
  | Lift (m a)
  | Halt String
  | GetSlots (L.List p -> a)
  | CheckSlot p (Boolean -> a)
  | ChildQuery p (Coyoneda g a)
  | Raise o a
  | Par (HalogenAp s f g p o m a)
  | Fork (FF.Fork (HalogenM s f g p o m) a)
  | GetRef RefLabel (Maybe Foreign -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s f g p o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe es a -> Subscribe es (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    CheckSlot p k -> CheckSlot p (map f k)
    GetSlots k -> GetSlots (map f k)
    ChildQuery p cq -> ChildQuery p (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s f g p o m a = HalogenAp (FreeAp (HalogenM s f g p o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f g p o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f g p o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f g p o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f g p o m)

newtype HalogenM s (f :: Type -> Type) g p o m a = HalogenM (Free (HalogenF s f g p o m) a)

instance functorHalogenM :: Functor (HalogenM s f g p o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM s f g p o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM s f g p o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM s f g p o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM s f g p o m)

instance monadEffHalogenM :: MonadEff eff m => MonadEff eff (HalogenM s f g p o m) where
  liftEff eff = HalogenM $ liftF $ Lift $ liftEff eff

instance monadAffHalogenM :: MonadAff eff m => MonadAff eff (HalogenM s f g p o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s f g p o m) (HalogenM s f g p o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadForkHalogenM :: MonadAff eff m => MonadFork Error (HalogenM s f g p o m) where
  fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

instance monadTransHalogenM :: MonadTrans (HalogenM s f g p o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM s f g p o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM s f g p o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM s f g p o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM s f g p o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s f g p o m a. String -> HalogenM s f g p o m a
halt msg = HalogenM $ liftF $ Halt msg

mkQuery
  :: forall s f g p o m a
   . Eq p
  => p
  -> g a
  -> HalogenM s f g p o m a
mkQuery p = HalogenM <<< liftF <<< ChildQuery p <<< coyoneda id

getSlots :: forall s f g p o m. HalogenM s f g p o m (L.List p)
getSlots = HalogenM $ liftF $ GetSlots id

checkSlot :: forall s f g p o m. p -> HalogenM s f g p o m Boolean
checkSlot p = HalogenM $ liftF $ CheckSlot p id

getRef :: forall s f g p o m. RefLabel -> HalogenM s f g p o m (Maybe Foreign)
getRef p = HalogenM $ liftF $ GetRef p id

-- | Provides a way of having a component subscribe to an `EventSource` from
-- | within an `Eval` function.
subscribe :: forall s f g p o m. ES.EventSource f m -> HalogenM s f g p o m Unit
subscribe es = HalogenM $ liftF $ Subscribe es unit

-- | Raises an output message for the component.
raise :: forall s f g p o m. o -> HalogenM s f g p o m Unit
raise o = HalogenM $ liftF $ Raise o unit

imapState
  :: forall s s' f g p o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM s  f g p o m
  ~> HalogenM s' f g p o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s f g p o m ~> HalogenF s' f g p o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe es next -> Subscribe es next
    Lift q -> Lift q
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapState f f') fo)
    GetRef p k -> GetRef p k

mapQuery
  :: forall s f f' g p o m
   . Functor m
  => (f ~> f')
  -> HalogenM s f  g p o m
  ~> HalogenM s f' g p o m
mapQuery nat (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f' g p o m
  go = case _ of
    State f -> State f
    Subscribe es next -> Subscribe (ES.interpret nat es) next
    Lift q -> Lift q
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapQuery nat)) p)
    Fork f -> Fork (FF.hoistFork (mapQuery nat) f)
    GetRef p k -> GetRef p k

mapChildQuery
  :: forall s f g g' p o m
   . (g ~> g')
  -> HalogenM s f g  p o m
  ~> HalogenM s f g' p o m
mapChildQuery nat (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f g' p o m
  go = case _ of
    State f -> State f
    Subscribe es next -> Subscribe es next
    Lift q -> Lift q
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p (hoistCoyoneda nat cq)
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapChildQuery nat)) p)
    Fork f -> Fork (FF.hoistFork (mapChildQuery nat) f)
    GetRef p k -> GetRef p k

imapSlots
  :: forall s f g p p' o m
   . (p -> p')
  -> (p' -> p)
  -> HalogenM s f g p  o m
  ~> HalogenM s f g p' o m
imapSlots f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f g p' o m
  go = case _ of
    State fs -> State fs
    Subscribe es next -> Subscribe es next
    Lift q -> Lift q
    Halt msg -> Halt msg
    GetSlots k -> GetSlots (k <<< map f')
    CheckSlot p k -> CheckSlot (f p) k
    ChildQuery p cq -> ChildQuery (f p) cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapSlots f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapSlots f f') fo)
    GetRef p k -> GetRef p k

mapOutput
  :: forall s f g p o o' m
   . (o -> o')
  -> HalogenM s f g p o  m
  ~> HalogenM s f g p o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f g p o' m
  go = case _ of
    State fs -> State fs
    Subscribe es next -> Subscribe es next
    Lift q -> Lift q
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork fo -> Fork (FF.hoistFork (mapOutput f) fo)
    GetRef p k -> GetRef p k

hoist
  :: forall s f g p o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM s f g p o m
  ~> HalogenM s f g p o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f g p o m'
  go = case _ of
    State f -> State f
    Subscribe es next -> Subscribe (ES.hoist nat es) next
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork f -> Fork (FF.hoistFork (hoist nat) f)
    GetRef p k -> GetRef p k

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Fork (class MonadFork)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)

import Data.Bifunctor (lmap)
import Data.Coyoneda (Coyoneda, coyoneda)
import Data.Foreign (Foreign)
import Data.List as L
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Tuple (Tuple)

import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.InputF (RefLabel)

-- | The Halogen component algebra
data HalogenF s (f :: Type -> Type) g p o m a
  = State (s -> Tuple a s)
  | Subscribe (ES.EventSource f m) a
  | Lift (m a)
  | Halt String
  | GetSlots (L.List p -> a)
  | CheckSlot p (Boolean -> a)
  | ChildQuery p (Coyoneda g a)
  | Raise o a
  | Par (HalogenAp s f g p o m a)
  | Fork (FF.Fork (HalogenM s f g p o m) a)
  | GetRef RefLabel (Maybe Foreign -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s f g p o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe es a -> Subscribe es (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    CheckSlot p k -> CheckSlot p (map f k)
    GetSlots k -> GetSlots (map f k)
    ChildQuery p cq -> ChildQuery p (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s f g p o m a = HalogenAp (FreeAp (HalogenM s f g p o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f g p o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f g p o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f g p o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f g p o m)

newtype HalogenM s (f :: Type -> Type) g p o m a = HalogenM (Free (HalogenF s f g p o m) a)

instance functorHalogenM :: Functor (HalogenM s f g p o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM s f g p o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM s f g p o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM s f g p o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM s f g p o m)

instance monadEffHalogenM :: MonadEff eff m => MonadEff eff (HalogenM s f g p o m) where
  liftEff eff = HalogenM $ liftF $ Lift $ liftEff eff

instance monadAffHalogenM :: MonadAff eff m => MonadAff eff (HalogenM s f g p o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s f g p o m) (HalogenM s f g p o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadForkHalogenM :: MonadAff eff m => MonadFork Error (HalogenM s f g p o m) where
  fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

instance monadTransHalogenM :: MonadTrans (HalogenM s f g p o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM s f g p o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM s f g p o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM s f g p o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM s f g p o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s f g p o m a. String -> HalogenM s f g p o m a
halt msg = HalogenM $ liftF $ Halt msg

mkQuery
  :: forall s f g p o m a
   . Eq p
  => p
  -> g a
  -> HalogenM s f g p o m a
mkQuery p = HalogenM <<< liftF <<< ChildQuery p <<< coyoneda id

getSlots :: forall s f g p o m. HalogenM s f g p o m (L.List p)
getSlots = HalogenM $ liftF $ GetSlots id

checkSlot :: forall s f g p o m. p -> HalogenM s f g p o m Boolean
checkSlot p = HalogenM $ liftF $ CheckSlot p id

getRef :: forall s f g p o m. RefLabel -> HalogenM s f g p o m (Maybe Foreign)
getRef p = HalogenM $ liftF $ GetRef p id

-- | Provides a way of having a component subscribe to an `EventSource` from
-- | within an `Eval` function.
subscribe :: forall s f g p o m. ES.EventSource f m -> HalogenM s f g p o m Unit
subscribe es = HalogenM $ liftF $ Subscribe es unit

-- | Raises an output message for the component.
raise :: forall s f g p o m. o -> HalogenM s f g p o m Unit
raise o = HalogenM $ liftF $ Raise o unit

hoist
  :: forall s f g p o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM s f g p o m
  ~> HalogenM s f g p o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s f g p o m ~> HalogenF s f g p o m'
  go = case _ of
    State f -> State f
    Subscribe es next -> Subscribe (ES.hoist nat es) next
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    GetSlots k -> GetSlots k
    CheckSlot p k -> CheckSlot p k
    ChildQuery p cq -> ChildQuery p cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork f -> Fork (FF.hoistFork (hoist nat) f)
    GetRef p k -> GetRef p k


Refactored logic for finding a square into its own function

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
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
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset 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 { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

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

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> findSquare squares coordinate

squareHasPiece :: Square -> Player -> Boolean
squareHasPiece square player = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece square player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

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

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
    guard $ hasPlayerPiece grid.squares player coordinate
    potential <- getDiagonalSquares coordinate
    guard $ isValidMove' grid player coordinate potential
    return potential
  where
    isValidMove' :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
    isValidMove' grid player from to =
      isValid grid to && not hasPiece grid.squares to &&
      (isRegularMove player from to || isJumpMove grid player from to)

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findSquare grid.squares coordinate)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
              n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
          in Just (Tuple n1 n2)
        else Nothing
  in
    case getMiddle from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

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

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      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 colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

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

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

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  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 (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
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
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

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

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset 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 { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

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

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

squareHasPiece :: Square -> Player -> Boolean
squareHasPiece square player = fromMaybe false $ (hasPlayer player) <$> square.piece

hasPlayerPiece :: Array Square -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> squareHasPiece square player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

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

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
    guard $ hasPlayerPiece grid.squares player coordinate
    potential <- getDiagonalSquares coordinate
    guard $ isValidMove' grid player coordinate potential
    return potential
  where
    isValidMove' :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
    isValidMove' grid player from to =
      isValid grid to && not hasPiece grid.squares to &&
      (isRegularMove player from to || isJumpMove grid player from to)

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
              n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
          in Just (Tuple n1 n2)
        else Nothing
  in
    case getMiddle from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

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

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      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 colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

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

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

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  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 (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit


Fix shadowed name warning

Fix shadowed name warning

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Data.CatQueue as Q
import Data.Foldable as Foldable
import Data.List as L
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Applicative (pure, class Applicative)
import Control.Apply ((<*>), class Apply)
import Control.Bind (class Bind)
import Control.Monad (ap, class Monad)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable)
import Data.Function (flip)
import Data.Functor ((<$>), class Functor)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty, class Monoid)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup (class Semigroup, (<>))
import Data.Show (class Show, show)
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

map :: forall a b. (a -> b) -> CatList a -> CatList b
map _ CatNil = CatNil
map f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a `cons` map f d

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap f l = foldMap f l
  foldl f s l = Foldable.foldlDefault f s l
  foldr f s l = Foldable.foldrDefault f s l

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map = map

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Data.CatQueue as Q
import Data.Foldable as Foldable
import Data.List as L
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Applicative (pure, class Applicative)
import Control.Apply ((<*>), class Apply)
import Control.Bind (class Bind)
import Control.Monad (ap, class Monad)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable)
import Data.Function (flip)
import Data.Functor ((<$>), class Functor)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty, class Monoid)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup (class Semigroup, (<>))
import Data.Show (class Show, show)
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k c (L.Cons b as) = foldl k (k c b) as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

map :: forall a b. (a -> b) -> CatList a -> CatList b
map _ CatNil = CatNil
map f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a `cons` map f d

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap f l = foldMap f l
  foldl f s l = Foldable.foldlDefault f s l
  foldr f s l = Foldable.foldrDefault f s l

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map = map

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList