Change code in order to comply with updated purescript-jquery API

module Main where

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

import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.State.Trans (StateT, modify, get, runStateT)
import Control.Monad.Eff.Class (liftEff)

import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import DOM (DOM)
import Ace as Ace
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, isChecked)

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

  historyCheckbox <- liftEff $ J.body >>= J.find "#historycheckbox"
  showHistory <- liftEff $ isChecked historyCheckbox

  if showHistory
    then do
      jq <- showHistoryList histExprs
      liftEff $ J.append jq history
      pure jq
    else liftEff $ do
      paragraph <- J.create "

"
      J.setText "hidden" paragraph
      J.append paragraph history
      pure paragraph

  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 $ do
    table <- J.create "

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

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

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

"
    J.addClass "history" hist
    pure hist
  tdExpr <- liftEff $ J.create "	"
  liftEff $ exprToJQuery out >>= flip J.append tdExpr
  liftEff $ (J.append tdExpr row *> pure 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 $ do
    button <- J.create "<button></button>"
    J.setText "Restore" button
    J.addClass "restore" button
    J.on "click" restoreHandler button
    pure button
  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 <- do
    paragraph <- J.create "

"
    J.addClass "info" paragraph
    J.setText ("Error in " <> origin <> " => " <> msg) paragraph
    pure paragraph
  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
  selection <- J.select ("#" <> name <> "-container")
  J.clear selection
  pure selection

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

"
  J.addClass name div
  J.append jq div
  pure div

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env: env, out: out } :: EvalState <- 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 $ do
    J.on "mouseover" handler jq
    pure 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
  pure 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 Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
import Data.Foreign (unsafeFromForeign)
import Data.Foldable (any)
import Data.Either (Either(Right, Left), either)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, print)
import Control.Monad.State.Trans (StateT, modify, get, runStateT)
import Control.Monad.Eff.Class (liftEff)

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

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

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

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

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

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  clearInfo
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue
  case parseExpr input of
    Left err   -> showInfo "Expression" (show err)
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
          showInfo "Definitions" (show err)
          markText (line - 1) column
        Right env -> case buildTypeEnv (envToDefs env) of --  type Env
          Left err -> showInfo "Definitions" (prettyPrintTypeError err)
          Right typEnv -> do
            let showEvalState typ' = let typ = txToABC typ' in
              let idTree = idExpr expr in
              void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
            case typeTreeProgramnEnv typEnv expr of
              Left err -> do
                showTypes
                let typ' = 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 _ -> return unit

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

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

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

  liftEff $ exprToJQuery out >>= wrapInDiv "output" >>= flip J.append output

  historyCheckbox <- liftEff $ J.body >>= J.find "#historycheckbox"
  showHistory <- liftEff $ isChecked historyCheckbox

  if showHistory
    then showHistoryList histExprs >>= liftEff <<< flip J.append history
    else liftEff $ J.create "

" >>= J.setText "hidden" >>=  flip J.append history

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

  liftEff $ return unit :: DOMEff Unit

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

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

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

" >>= J.addClass "scroll"
  liftEff $ J.append box scroll
  return scroll

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

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

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

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

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

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

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

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

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

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

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

addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
addClickListener typeTree jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    mpath <- getPath jq
    case mpath of
      Nothing   -> return unit
      Just path -> do
        return unit
        if checkForError path typeTree
          then return unit
          else case ctrlKeyPressed jEvent of
                false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
                true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

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

evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
evalExpr eval path = do
  { env: env, out: out, typEnv: typEnv} <- get
  let expr = out.expr
  -- liftEff $ print path
  case eval env path expr of
    Left msg    -> return unit
    Right expr' -> do
        let eitherTyp = typeTreeProgramnEnv typEnv expr'
        let typ'' = either (\_ -> 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


Changed renderLine to fold over a list instead of an array for a 3% 'boost'

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Function
import Data.Int
import Data.List as L
import Data.Int.Bits
import Data.Foldable
import Data.Functor
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import MemSection as M
import Debug

foreign import setCanvasPixelColor :: forall e. Int -> Palette -> Int -> Int
                              -> Eff (canvas :: Canvas | e) Unit

foreign import setScreen :: forall e. Context2D
                         -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

--NOTE: could be redundant after scrBuf is gone
resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = return unit

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : M.getNew 16 0
  , mode : VBlank
  , tiles : Tiles $ M.getNew (384*64) 0
  , regs : M.getNew 0x40 0
  , vram : M.getNew 8192 0
  , oam : M.getNew 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas, ma :: MemAccess | e) Gpu
gpuStep _ gpu@{dispOn = false} = return gpu

gpuStep opTime gpu@{mTimer,mode,currLine,currPos,vblFinish} =
  map hblCurrLineEarlyReset eGpu'
 where
  mTimer' = mTimer + opTime

  eGpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                {--traceA "draw!"--}
                setScreen =<< getCanvas

                return $ gp { mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine $ gpu { mTimer = mTimer' - modeDuration HBlank
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if vblFinish
                -- 10 increments after last line of 143
                then _ { vblFinish = false
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = mTimer' - modeDuration VBlank , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = mTimer' - modeDuration OamScan, mode = VramScan }
      VramScan ->
        let renderOrNot = if gpu.dispOn && gpu.bgOn then renderLine else return
        in renderOrNot gpu { mTimer = mTimer' - modeDuration VramScan, mode = HBlank }

hblCurrLineEarlyReset :: Gpu -> Gpu
hblCurrLineEarlyReset gpu@{mTimer = mTimer', currLine, mode} =
  if mode == VBlank && mTimer' >= 4 && currLine == pixHeight + 10 - 1
    then gpu { currLine = 0, vblFinish = true }
    else gpu

--Change condition of renderOrNot once object rendering is added
--And perhaps rename the current renderLine to renderBG and have renderLine
--be what calls renderBG and renderFG
{--renderLine :: Gpu -> forall e. Eff (canvas :: Canvas | e) Gpu--}
renderLine :: forall e. Gpu -> Eff (ma :: MemAccess, canvas :: Canvas | e) Gpu
renderLine gpu = do
  tileIx <- getTileIx gpu tileIxAddr
  foldRes <- L.foldM updateCanvas
                     { tho:tileHorizOff
                     , mho:memHorizOff, tix:tileIx }
                     (0 L... (pixWidth-1))
  return gpu
 where
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  setCanvasPixelColor' = mkFn4 setCanvasPixelColor

  updateCanvas {tho,mho,tix} i = do
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    let tho' = if lastTileRowPixel
          then 0
          else tho + 1
        mho' = if lastTileRowPixel
          then 31 .&. (1 + mho)
          else mho
    tix' <- if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else return tix

    --NOTE trace error, if invalid color ix
    colorIx <- getTilePixel tho tileVertOff tix gpu.tiles

    runFn4 setCanvasPixelColor' colorIx pal (i*4) gpu.currLine
    return $ {tho:tho',mho:mho',tix:tix'}
   where
    lastTileRowPixel = tho == 7
    pal = gpu.palette

getTileIx :: forall e. Gpu -> I16 -> Eff (ma :: MemAccess | e) I8
getTileIx { vram, bgSet1 } addr = do
  tix <- vram M.!! addr
  return $ if (not bgSet1) then tix + 256 else tix

gpuRd8 :: forall e. I16 -> Gpu -> Eff (ma :: MemAccess | e) I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> return $ getCtrlFlags gpu
  0xFF42 -> return gpu.yScroll
  0xFF43 -> return gpu.xScroll
  0xFF44 -> return gpu.currLine
  0xFF47 -> return $ -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs M.!! (addr - 0xFF40)

gpuWr8 :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Gpu
gpuWr8 i8 addr gpu = do
  setRegs
  case addr of
    0xFF40 -> return $ setCtrlFlags i8 gpu
    0xFF42 -> return gpu { yScroll = i8 }
    0xFF43 -> return gpu { xScroll = i8 }
    0xFF44 -> return gpu { currLine = i8 }
    0xFF47 -> setPalette
    otherwise -> return gpu
 where
  setRegs = M.replace i8 (addr - 0xFF40) gpu.regs
  setPalette = gpu <$ traverse_ stPl (0 A... 3)
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> setColor {a:255,r:255,g:255,b:255} i gpu.palette
    1 -> setColor {a:192,r:192,g:192,b:255} i gpu.palette
    2 -> setColor {a:96 ,r:96 ,g:96 ,b:255} i gpu.palette
    3 -> setColor {a:0  ,r:0  ,g:0  ,b:255} i gpu.palette
    otherwise -> return unit -- NOTE log this

{--getColor :: forall e. Int -> Palette--}
         {---> Eff (ma :: MemAccess | e) {a :: Int, r :: Int, g :: Int, b :: Int}--}
{--getColor cIx pal = do--}
  {--a <- M.zubi pal i--}
  {--r <- M.zubi pal (i + 1)--}
  {--g <- M.zubi pal (i + 2)--}
  {--b <- M.zubi pal (i + 3)--}
  {--return {a,r,g,b}--}
 {--where i = cIx*4--}

setColor :: forall e. {a :: Int, r :: Int, g :: Int, b :: Int} -> Int -> Palette
         -> Eff (ma :: MemAccess | e) Unit
setColor {a,r,g,b} cIx pal = do
  M.replace a i pal
  M.replace r (i + 1) pal
  M.replace g (i + 2) pal
  M.replace b (i + 3) pal
  return unit
 where i = cIx*4

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

setCtrlFlags :: I8 -> Gpu -> Gpu
setCtrlFlags ctrlFlags gpu = enableDisableOrNot gpu.dispOn dispOn'
  gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = dispOn'
    }
 where
  isFlagSet flag = (flag .&. ctrlFlags) /= 0
  dispOn' = isFlagSet 0x80

  enableDisableOrNot true false = disableGpu
  enableDisableOrNot false true = enableGpu
  enableDisableOrNot _ _ = id

disableGpu :: Gpu -> Gpu
disableGpu gpu = gpu
  { mTimer = 0
  , currLine = 0
  , mode = HBlank
  , vblFinish = false
  , dispOn = false
  }

enableGpu :: Gpu -> Gpu
enableGpu gpu = gpu
  { mTimer = 0
  , mode = OamScan
  , dispOn = true
  }

wrVRam :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Unit
wrVRam i8 addr gpu@{vram,tiles} = do
  vram' <- M.replace i8 addr' vram
  if (addr >= 0x8000 && addr < 0x9800)
    then vramWriteToTiles addr' vram' tiles
    else return unit
 where
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF
--2 tile maps from 0x9800 to 0x9FFF

vramWriteToTiles :: forall e. I16 -> MemSection -> Tiles -> Eff (ma :: MemAccess | e) Unit
vramWriteToTiles addr vram tiles =
  traverse_ updateColor (0 A... 7)
 where
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: forall e. Int -> Eff (ma :: MemAccess | e) Unit
  updateColor x = do
    highColors <- vram M.!! addr + 1
    lowColors <- vram M.!! addr
    let c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
         .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)
    setTilePixel c x y tileIx tiles
   where
    shiftMask = 1 `shl` (7-x)

--NOTE Add a check that tile index is valid (0<=i<384)

getTilePixel :: forall e. Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Int
getTilePixel x y tileIx (Tiles ms) = ms M.!! (tileIx*64) + (y*8) + x

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: forall e. Int -> Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Unit
setTilePixel c x y tileIx (Tiles ms) = void
  $ M.replace c ((tileIx*64) + (y*8) + x) ms

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Function
import Data.Int
import Data.Int.Bits
import Data.Foldable
import Data.Functor
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import MemSection as M
import Debug

foreign import setCanvasPixelColor :: forall e. Int -> Palette -> Int -> Int
                              -> Eff (canvas :: Canvas | e) Unit

foreign import setScreen :: forall e. Context2D
                         -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

--NOTE: could be redundant after scrBuf is gone
resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = return unit

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : M.getNew 16 0
  , mode : VBlank
  , tiles : Tiles $ M.getNew (384*64) 0
  , regs : M.getNew 0x40 0
  , vram : M.getNew 8192 0
  , oam : M.getNew 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas, ma :: MemAccess | e) Gpu
gpuStep _ gpu@{dispOn = false} = return gpu

gpuStep opTime gpu@{mTimer,mode,currLine,currPos,vblFinish} =
  map hblCurrLineEarlyReset eGpu'
 where
  mTimer' = mTimer + opTime

  eGpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                {--traceA "draw!"--}
                setScreen =<< getCanvas

                return $ gp { mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine $ gpu { mTimer = mTimer' - modeDuration HBlank
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if vblFinish
                -- 10 increments after last line of 143
                then _ { vblFinish = false
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = mTimer' - modeDuration VBlank , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = mTimer' - modeDuration OamScan, mode = VramScan }
      VramScan ->
        let renderOrNot = if gpu.dispOn && gpu.bgOn then renderLine else return
        in renderOrNot gpu { mTimer = mTimer' - modeDuration VramScan, mode = HBlank }

hblCurrLineEarlyReset :: Gpu -> Gpu
hblCurrLineEarlyReset gpu@{mTimer = mTimer', currLine, mode} =
  if mode == VBlank && mTimer' >= 4 && currLine == pixHeight + 10 - 1
    then gpu { currLine = 0, vblFinish = true }
    else gpu

--Change condition of renderOrNot once object rendering is added
--And perhaps rename the current renderLine to renderBG and have renderLine
--be what calls renderBG and renderFG
{--renderLine :: Gpu -> forall e. Eff (canvas :: Canvas | e) Gpu--}
renderLine :: forall e. Gpu -> Eff (ma :: MemAccess, canvas :: Canvas | e) Gpu
renderLine gpu = do
  tileIx <- getTileIx gpu tileIxAddr
  foldRes <- A.foldM updateCanvas
                     { tho:tileHorizOff
                     , mho:memHorizOff, tix:tileIx }
                     (0 A... (pixWidth-1))
  return gpu
 where
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  setCanvasPixelColor' = mkFn4 setCanvasPixelColor

  updateCanvas {tho,mho,tix} i = do
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    let tho' = if lastTileRowPixel
          then 0
          else tho + 1
        mho' = if lastTileRowPixel
          then 31 .&. (1 + mho)
          else mho
    tix' <- if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else return tix

    --NOTE trace error, if invalid color ix
    colorIx <- getTilePixel tho tileVertOff tix gpu.tiles

    runFn4 setCanvasPixelColor' colorIx pal (i*4) gpu.currLine
    return $ {tho:tho',mho:mho',tix:tix'}
   where
    lastTileRowPixel = tho == 7
    pal = gpu.palette

getTileIx :: forall e. Gpu -> I16 -> Eff (ma :: MemAccess | e) I8
getTileIx { vram, bgSet1 } addr = do
  tix <- vram M.!! addr
  return $ if (not bgSet1) then tix + 256 else tix

gpuRd8 :: forall e. I16 -> Gpu -> Eff (ma :: MemAccess | e) I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> return $ getCtrlFlags gpu
  0xFF42 -> return gpu.yScroll
  0xFF43 -> return gpu.xScroll
  0xFF44 -> return gpu.currLine
  0xFF47 -> return $ -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs M.!! (addr - 0xFF40)

gpuWr8 :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Gpu
gpuWr8 i8 addr gpu = do
  setRegs
  case addr of
    0xFF40 -> return $ setCtrlFlags i8 gpu
    0xFF42 -> return gpu { yScroll = i8 }
    0xFF43 -> return gpu { xScroll = i8 }
    0xFF44 -> return gpu { currLine = i8 }
    0xFF47 -> setPalette
    otherwise -> return gpu
 where
  setRegs = M.replace i8 (addr - 0xFF40) gpu.regs
  setPalette = gpu <$ traverse_ stPl (0 A... 3)
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> setColor {a:255,r:255,g:255,b:255} i gpu.palette
    1 -> setColor {a:192,r:192,g:192,b:255} i gpu.palette
    2 -> setColor {a:96 ,r:96 ,g:96 ,b:255} i gpu.palette
    3 -> setColor {a:0  ,r:0  ,g:0  ,b:255} i gpu.palette
    otherwise -> return unit -- NOTE log this

{--getColor :: forall e. Int -> Palette--}
         {---> Eff (ma :: MemAccess | e) {a :: Int, r :: Int, g :: Int, b :: Int}--}
{--getColor cIx pal = do--}
  {--a <- M.zubi pal i--}
  {--r <- M.zubi pal (i + 1)--}
  {--g <- M.zubi pal (i + 2)--}
  {--b <- M.zubi pal (i + 3)--}
  {--return {a,r,g,b}--}
 {--where i = cIx*4--}

setColor :: forall e. {a :: Int, r :: Int, g :: Int, b :: Int} -> Int -> Palette
         -> Eff (ma :: MemAccess | e) Unit
setColor {a,r,g,b} cIx pal = do
  M.replace a i pal
  M.replace r (i + 1) pal
  M.replace g (i + 2) pal
  M.replace b (i + 3) pal
  return unit
 where i = cIx*4

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

setCtrlFlags :: I8 -> Gpu -> Gpu
setCtrlFlags ctrlFlags gpu = enableDisableOrNot gpu.dispOn dispOn'
  gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = dispOn'
    }
 where
  isFlagSet flag = (flag .&. ctrlFlags) /= 0
  dispOn' = isFlagSet 0x80

  enableDisableOrNot true false = disableGpu
  enableDisableOrNot false true = enableGpu
  enableDisableOrNot _ _ = id

disableGpu :: Gpu -> Gpu
disableGpu gpu = gpu
  { mTimer = 0
  , currLine = 0
  , mode = HBlank
  , vblFinish = false
  , dispOn = false
  }

enableGpu :: Gpu -> Gpu
enableGpu gpu = gpu
  { mTimer = 0
  , mode = OamScan
  , dispOn = true
  }

wrVRam :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Unit
wrVRam i8 addr gpu@{vram,tiles} = do
  vram' <- M.replace i8 addr' vram
  if (addr >= 0x8000 && addr < 0x9800)
    then vramWriteToTiles addr' vram' tiles
    else return unit
 where
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF
--2 tile maps from 0x9800 to 0x9FFF

vramWriteToTiles :: forall e. I16 -> MemSection -> Tiles -> Eff (ma :: MemAccess | e) Unit
vramWriteToTiles addr vram tiles =
  traverse_ updateColor (0 A... 7)
 where
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: forall e. Int -> Eff (ma :: MemAccess | e) Unit
  updateColor x = do
    highColors <- vram M.!! addr + 1
    lowColors <- vram M.!! addr
    let c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
         .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)
    setTilePixel c x y tileIx tiles
   where
    shiftMask = 1 `shl` (7-x)

--NOTE Add a check that tile index is valid (0<=i<384)

getTilePixel :: forall e. Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Int
getTilePixel x y tileIx (Tiles ms) = ms M.!! (tileIx*64) + (y*8) + x

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: forall e. Int -> Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Unit
setTilePixel c x y tileIx (Tiles ms) = void
  $ M.replace c ((tileIx*64) + (y*8) + x) ms

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144


doc string added

doc string added

module RNX where

import Prelude
import Control.Monad.Aff (Aff, launchAff, later)
--import Control.Monad.Aff.Unsafe (unsafeInterleaveAff)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foldable (foldl, sequence_)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.List (List(Nil), singleton, (:), reverse, fromFoldable)
import Data.Maybe (fromJust)
import Partial.Unsafe (unsafePartial)
import Signal (Signal, (~>), mergeMany, foldp, runSignal)
import Signal.Channel (CHANNEL, Channel, channel, subscribe, send)
import RNX.Components

-- | AppKey : Used to define the application name which will be registered with React Native
type AppKey = String

-- | Used to render the application
foreign import render :: forall a eff. Fn3 (a -> Eff eff Unit) (a -> a) (Element a) (Element a)

-- | Register the component
foreign import registerComponent :: forall a e. AppKey -> a ->  Eff e Unit

-- | Config state action eff. This is the application configuration type
type Config state action eff =
  { update :: Update state action eff
  , view :: state -> Element action
  , initialState :: state
  , inputs :: Array (Signal action)
  }

-- | Type of the update function
type Update state action eff = action -> state -> EffModel state action eff

-- | Return type of the update function
type EffModel state action eff =
  { state :: state
  , effects :: Array (Aff (CoreEffects eff) action)
  }

-- | Type of the core effects of RNX
type CoreEffects eff = (channel :: CHANNEL, err :: EXCEPTION | eff)

-- | App type
type App state action =
  { html :: Signal (Element action)
  , state :: Signal state
  , actionChannel :: Channel (List action)
  }

-- | Create an `Update` function from a simple step function.
fromSimple :: forall s a eff. (a -> s -> s) -> Update s a eff
fromSimple update = \action state -> noEffects $ update action state

-- | Create an `EffModel` with no effects from a given state.
noEffects :: forall state action eff. state -> EffModel state action eff
noEffects state = { state: state, effects: [] }

-- | Create an `EffModel` with the given state and effects
onlyEffects :: forall state action eff.
               state -> Array (Aff (CoreEffects eff) action) -> EffModel state action eff
onlyEffects state effects = { state: state, effects: effects }

-- | Map over the state of an `EffModel`.
mapState :: forall sa sb a e. (sa -> sb) -> EffModel sa a e -> EffModel sb a e
mapState a2b effmodel =
  { state: a2b effmodel.state, effects: effmodel.effects }

-- | Map over the effectful actions of an `EffModel`.
mapEffects :: forall s a b e. (a -> b) -> EffModel s a e -> EffModel s b e
mapEffects action effmodel =
  { state: effmodel.state, effects: map (map action) effmodel.effects }

-- | Start the application with the given configuration
start :: forall state action eff.
         Config state action eff ->
         Eff (CoreEffects eff) (App state action)
start config = do
  actionChannel <- channel Nil
  let actionSignal = subscribe actionChannel
      input = unsafePartial $ fromJust $ mergeMany $
        reverse (actionSignal : map (map singleton) (fromFoldable $ config.inputs))
      foldState effModel action = config.update action effModel.state
      foldActions actions effModel =
        foldl foldState (noEffects effModel.state) actions
      effModelSignal =
        foldp foldActions (noEffects config.initialState) input
      stateSignal = effModelSignal ~> _.state
      htmlSignal = stateSignal ~> \state ->
        (runFn3 render) (send actionChannel <<< singleton) (\a -> a) (config.view state)
      mapAffect affect = launchAff $ unsafeCoerceAff do
        action <- later affect
        liftEff $ send actionChannel (singleton action)
      effectsSignal = effModelSignal ~> map mapAffect <<< _.effects
  runSignal $ effectsSignal ~> sequence_
  pure $ { html: htmlSignal, state: stateSignal, actionChannel: actionChannel }

module RNX where

import Prelude
import Control.Monad.Aff (Aff, launchAff, later)
--import Control.Monad.Aff.Unsafe (unsafeInterleaveAff)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foldable (foldl, sequence_)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.List (List(Nil), singleton, (:), reverse, fromFoldable)
import Data.Maybe (fromJust)
import Partial.Unsafe (unsafePartial)
import Signal (Signal, (~>), mergeMany, foldp, runSignal)
import Signal.Channel (CHANNEL, Channel, channel, subscribe, send)
import RNX.Components

type AppKey = String

foreign import render :: forall a eff. Fn3 (a -> Eff eff Unit) (a -> a) (Element a) (Element a)

-- registerComponent
foreign import registerComponent :: forall a e. AppKey -> a ->  Eff e Unit

-- Types

type Config state action eff =
  { update :: Update state action eff
  , view :: state -> Element action
  , initialState :: state
  , inputs :: Array (Signal action)
  }

type Update state action eff = action -> state -> EffModel state action eff

type EffModel state action eff =
  { state :: state
  , effects :: Array (Aff (CoreEffects eff) action) }

type CoreEffects eff = (channel :: CHANNEL, err :: EXCEPTION | eff)

type App state action =
  { html :: Signal (Element action)
  , state :: Signal state
  , actionChannel :: Channel (List action)
  }

-- functions

-- | Create an `Update` function from a simple step function.
fromSimple :: forall s a eff. (a -> s -> s) -> Update s a eff
fromSimple update = \action state -> noEffects $ update action state

-- | Create an `EffModel` with no effects from a given state.
noEffects :: forall state action eff. state -> EffModel state action eff
noEffects state = { state: state, effects: [] }

onlyEffects :: forall state action eff.
               state -> Array (Aff (CoreEffects eff) action) -> EffModel state action eff
onlyEffects state effects = { state: state, effects: effects }

-- | Map over the state of an `EffModel`.
mapState :: forall sa sb a e. (sa -> sb) -> EffModel sa a e -> EffModel sb a e
mapState a2b effmodel =
  { state: a2b effmodel.state, effects: effmodel.effects }

-- | Map over the effectful actions of an `EffModel`.
mapEffects :: forall s a b e. (a -> b) -> EffModel s a e -> EffModel s b e
mapEffects action effmodel =
  { state: effmodel.state, effects: map (map action) effmodel.effects }

---- start function

start :: forall state action eff.
         Config state action eff ->
         Eff (CoreEffects eff) (App state action)
start config = do
  actionChannel <- channel Nil
  let actionSignal = subscribe actionChannel
      input = unsafePartial $ fromJust $ mergeMany $
        reverse (actionSignal : map (map singleton) (fromFoldable $ config.inputs))
      foldState effModel action = config.update action effModel.state
      foldActions actions effModel =
        foldl foldState (noEffects effModel.state) actions
      effModelSignal =
        foldp foldActions (noEffects config.initialState) input
      stateSignal = effModelSignal ~> _.state
      htmlSignal = stateSignal ~> \state ->
        (runFn3 render) (send actionChannel <<< singleton) (\a -> a) (config.view state)
      mapAffect affect = launchAff $ unsafeCoerceAff do
        action <- later affect
        liftEff $ send actionChannel (singleton action)
      effectsSignal = effModelSignal ~> map mapAffect <<< _.effects
  runSignal $ effectsSignal ~> sequence_
  pure $ { html: htmlSignal, state: stateSignal, actionChannel: actionChannel }


Guard ActionList filter description inputs

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.ActionList.Filter.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Render.Common as RC

type State =
  { description ∷ String
  , filter ∷ String
  }

data Query a
  = Set String a
  | Get (String → a)
  | UpdateDescription String a

data Message = FilterChanged String

type Input = String

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.component
    { initialState:
        { description: _
        , filter: ""
        }
    , render
    , eval
    , receiver: HE.input UpdateDescription
    }

render ∷ State → HTML
render state =
  HH.form [ HP.classes [ HH.ClassName "sd-action-filter" ] ]
    [ HH.div_
        [ HH.div
            [ HP.classes [ HH.ClassName "sd-action-filter-icon" ] ]
            [ RC.searchFieldIcon ]
        , HH.input
            [ HP.value state.filter
            , HE.onValueInput $ HE.input \s → Set s
            , ARIA.label state.description
            , HP.placeholder state.description
            ]
        , HH.button
            [ HP.type_ HP.ButtonButton
            , HE.onClick $ HE.input_ $ Set ""
            , HP.enabled $ state.filter ≠ ""
            ]
            [ RC.clearFieldIcon "Clear filter" ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Set s next → do
    H.modify _{ filter = s }
    pure next
  Get cont → do
    H.gets $ cont ∘ _.filter
  UpdateDescription newDesc next -> do
    oldDesc ← H.gets _.description
    when (oldDesc /= newDesc) $
      H.modify _{ description = newDesc }
    pure next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.ActionList.Filter.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Render.Common as RC

type State =
  { description ∷ String
  , filter ∷ String
  }

data Query a
  = Set String a
  | Get (String → a)
  | UpdateDescription String a

data Message = FilterChanged String

type Input = String

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.component
    { initialState:
        { description: _
        , filter: ""
        }
    , render
    , eval
    , receiver: HE.input UpdateDescription
    }

render ∷ State → HTML
render state =
  HH.form [ HP.classes [ HH.ClassName "sd-action-filter" ] ]
    [ HH.div_
        [ HH.div
            [ HP.classes [ HH.ClassName "sd-action-filter-icon" ] ]
            [ RC.searchFieldIcon ]
        , HH.input
            [ HP.value state.filter
            , HE.onValueInput $ HE.input \s → Set s
            , ARIA.label state.description
            , HP.placeholder state.description
            ]
        , HH.button
            [ HP.type_ HP.ButtonButton
            , HE.onClick $ HE.input_ $ Set ""
            , HP.enabled $ state.filter ≠ ""
            ]
            [ RC.clearFieldIcon "Clear filter" ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Set s next → do
    H.modify _{ filter = s }
    pure next
  Get cont → do
    H.gets $ cont ∘ _.filter
  UpdateDescription s next -> do
    H.modify _{ description = s }
    pure next


Redefine Renderer to emphasize purity, possibility of failure, add function to create GWAS renderer

module Genetics.Browser.TruTrack where

import Prelude

import Color (Color)
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Reader (class MonadReader, Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, for_, length, maximum, minimum, sum)
import Data.List (List(..), mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Record.Unsafe (unsafeSet)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Unfoldable (unfoldr)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Graphics.Drawing (Drawing, circle, fillColor, filled, outlineColor, outlined, translate)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx

        let r = 1.0
            x = (unwrap $ f.pos / size) - r
            y = (f.score - min / max - min) - r
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill
        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

                  , point :: a -> Normalized Point
                  }

drawFrame :: forall a r.
             { width :: Pixels
             , padding :: Pixels
             , height :: Pixels
             , frame :: Frame (Array a) | r}
          -> Renderer a
          -> Drawing
drawFrame {width, padding, height, frame} {draw, point} = foldMap draw' frame.contents
  where draw' a = let {x,y} = nPointToFrame (width - padding * 2.0) height $ point a
                      drawing = draw a
                  in translate (x + padding) y drawing

offsets :: forall f r.
           Traversable f
        => f { width :: Pixels | r }
        -> f Pixels
offsets fs = scanl (\o {width} -> width + o) 0.0 fs

addOffsets :: forall k r.
              Ord k
           => Map k { width :: Pixels | r }
           -> Map k { width :: Pixels, offset :: Pixels | r }
addOffsets fs = zipMapsWith (unsafeSet "offset") os fs
  where os = offsets fs

-- We simply throw away existing width, offset, height data if it exists
fitFrames :: forall f a r.
             Foldable f
          => Pixels
          -> f { size :: Bp | r }
          -> f { width :: Pixels
               , offset :: Pixels | r }
fitFrames totalWidth fs = unsafeCoerce unit
  where totalSize = alaF Additive foldMap _.size fs
        w size = unwrap $ size / totalSize

-- TODO reasonable way of defining frame/track y-position, based on:

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

-- type Renderer eff a =
--   { hPos :: a -> XPosInfo -> Pixels
--   , vPos :: a -> YPosInfo -> Pixels
--   , render :: a -> Context2D -> Eff eff Unit
--   , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
--   }

-- gwasRenderer :: forall a.
--                 {min :: Number, max :: Number}
--              -> (a -> String)
--              -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
-- gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
--   where hPos a xInfo = posPixelsX xInfo a.pos
--         nScore s = (s - min) / (max - min)
--         vPos a yInfo = posPixelsY yInfo (nScore a.score)
--         render a ctx = renderGlyph ctx $ do
--           stroke (color a.chr)
--           fill (color a.chr)
--           circle { x: 0.0, y: 0.0 } 5.0

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

chrSubrange :: forall a r.
               Range r
            -> Map ChrId a
            -> Map ChrId a
chrSubrange {lHand, rHand} = Map.submap (Just lHand.chrId) (Just rHand.chrId)

-- renderFrame :: _
-- renderFrame = ?idk

fetchGemma :: String
           -> Aff _ (List { chr :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chr <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chr, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

module Genetics.Browser.TruTrack where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Reader (class MonadReader, Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, for_, length, maximum, minimum, sum)
import Data.List (List(..), mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Record.Unsafe (unsafeSet)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Unfoldable (unfoldr)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Graphics.Drawing (Drawing, translate)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
type Renderer a = { draw :: a -> Drawing
                  , point :: a -> Normalized Point
                  }

drawFrame :: forall a r.
             { width :: Pixels
             , padding :: Pixels
             , height :: Pixels
             , frame :: Frame (Array a) | r}
          -> Renderer a
          -> Drawing
drawFrame {width, padding, height, frame} {draw, point} = foldMap draw' frame.contents
  where draw' a = let {x,y} = nPointToFrame (width - padding * 2.0) height $ point a
                      drawing = draw a
                  in translate (x + padding) y drawing

offsets :: forall f r.
           Traversable f
        => f { width :: Pixels | r }
        -> f Pixels
offsets fs = scanl (\o {width} -> width + o) 0.0 fs

addOffsets :: forall k r.
              Ord k
           => Map k { width :: Pixels | r }
           -> Map k { width :: Pixels, offset :: Pixels | r }
addOffsets fs = zipMapsWith (unsafeSet "offset") os fs
  where os = offsets fs

-- We simply throw away existing width, offset, height data if it exists
fitFrames :: forall f a r.
             Foldable f
          => Pixels
          -> f { size :: Bp | r }
          -> f { width :: Pixels
               , offset :: Pixels | r }
fitFrames totalWidth fs = unsafeCoerce unit
  where totalSize = alaF Additive foldMap _.size fs
        w size = unwrap $ size / totalSize

-- TODO reasonable way of defining frame/track y-position, based on:

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

-- type Renderer eff a =
--   { hPos :: a -> XPosInfo -> Pixels
--   , vPos :: a -> YPosInfo -> Pixels
--   , render :: a -> Context2D -> Eff eff Unit
--   , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
--   }

-- gwasRenderer :: forall a.
--                 {min :: Number, max :: Number}
--              -> (a -> String)
--              -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
-- gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
--   where hPos a xInfo = posPixelsX xInfo a.pos
--         nScore s = (s - min) / (max - min)
--         vPos a yInfo = posPixelsY yInfo (nScore a.score)
--         render a ctx = renderGlyph ctx $ do
--           stroke (color a.chr)
--           fill (color a.chr)
--           circle { x: 0.0, y: 0.0 } 5.0

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

chrSubrange :: forall a r.
               Range r
            -> Map ChrId a
            -> Map ChrId a
chrSubrange {lHand, rHand} = Map.submap (Just lHand.chrId) (Just rHand.chrId)

-- renderFrame :: _
-- renderFrame = ?idk

fetchGemma :: String
           -> Aff _ (List { chr :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chr <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chr, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs


Fixed Router - regex to the rescue

Fixed Router - regex to the rescue

For one reason or another pux routing stopped working for me again.

Now I am simply using a good old regex and it is working again! :-)

module Gonimo.Client.Router where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(Right, Left))
import Data.Functor ((<$))
import Data.Maybe (fromMaybe)
import Global (decodeURIComponent)
import Gonimo.Types (Secret(Secret))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (($), (<$>))
import Pux.Router (param, router, lit, int, end)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece)
import Debug.Trace (trace)
import Data.Maybe (Maybe(..))
import Data.Array (index)
import Data.Either (fromRight)
import Partial.Unsafe (unsafePartial)

import Data.String.Regex as R

data Route = Home | AcceptInvitation Secret | DecodingFailed String

data RouteP = HomeP | AcceptInvitationP String | DecodingFailedP String

render (AcceptInvitation secret) = "acceptInvitation=" <> gDefaultEncodeURLPiece secret
render Home = ""

match' :: String -> RouteP
-- match' url =trace ("Routing: " <> url) $ \_ -> (fromMaybe (DecodingFailedP $ "No such route: " <> url) $ router url $
--        AcceptInvitationP <$> (lit "index.html" *> param "acceptInvitation") <* end
--    <|> HomeP <$ lit "index.html" <* end
-- )
match' url = let
    matcher = unsafePartial $ fromRight $ R.regex ".*acceptInvitation=([^&]*)" R.noFlags
    matched = R.match matcher url
  in
     case matched of
       Nothing -> HomeP
       Just arr -> case index arr 1 of
         Nothing -> HomeP
         (Just Nothing) -> HomeP
         (Just (Just val)) -> AcceptInvitationP val

match :: String -> Route
match url = let r' = match' url
            in case r' of
              HomeP -> trace ("Routing: " <> url <> ", to Home") $ \_ -> Home
              DecodingFailedP err -> trace ("Routing:" <> url <> ", to DecodingFailed") $ \_ -> DecodingFailed err
              AcceptInvitationP str -> trace ("Routing:" <> url <> ", to AcceptInvitationP, match: " <> str) $ \_ ->
                let eVal = Aeson.decodeJson =<< (jsonParser <<< decodeURIComponent) str
                in case eVal of
                  Left err  -> DecodingFailed err
                  Right val -> AcceptInvitation val

module Gonimo.Client.Router where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(Right, Left))
import Data.Functor ((<$))
import Data.Maybe (fromMaybe)
import Global (decodeURIComponent)
import Gonimo.Types (Secret(Secret))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (($), (<$>))
import Pux.Router (param, router, lit, int, end)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece)

data Route = Home | AcceptInvitation Secret | DecodingFailed String

data RouteP = HomeP | AcceptInvitationP String | DecodingFailedP String

render (AcceptInvitation secret) = "acceptInvitation=" <> gDefaultEncodeURLPiece secret
render Home = ""

match' :: String -> RouteP
match' url = fromMaybe (DecodingFailedP $ "No such route: " <> url) $ router url $
       AcceptInvitationP <$> (lit "index.html" *> param "acceptInvitation") <* end
   <|> HomeP <$ lit "index.html" <* end

match :: String -> Route
match url = let r' = match' url
            in case r' of
              HomeP -> Home
              DecodingFailedP err -> DecodingFailed err
              AcceptInvitationP str ->
                let eVal = Aeson.decodeJson =<< (jsonParser <<< decodeURIComponent) str
                in case eVal of
                  Left err  -> DecodingFailed err
                  Right val -> AcceptInvitation val


Update for new pursuit json field

Update for new pursuit json field

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String)
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport String

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeJson matcher)
      ~> "currentModule" := (encodeJson currentModule)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeJson currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeJson outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> jsonEmptyObject
      )

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String
))
newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }
newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList (Array Import)
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = {line :: Int, column :: Int}

newtype RebuildError =
  RebuildError
  { position :: Maybe Position
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. (DecodeJson a, DecodeJson b) => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    text <- o .? "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = do
    imports <- decodeJson json
    pure (ImportList imports)

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pure (RebuildError { errorCode, moduleName, filename, message, position})
    where
      eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String)
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport String

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeJson matcher)
      ~> "currentModule" := (encodeJson currentModule)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeJson currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeJson outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> jsonEmptyObject
      )

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String
))
newtype PursuitCompletion = PursuitCompletion (GenCompletion (package :: String))
newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList (Array Import)
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = {line :: Int, column :: Int}

newtype RebuildError =
  RebuildError
  { position :: Maybe Position
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. (DecodeJson a, DecodeJson b) => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = do
    imports <- decodeJson json
    pure (ImportList imports)

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pure (RebuildError { errorCode, moduleName, filename, message, position})
    where
      eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))