slightly better names, explicit main type annotation

module Main where

import Prelude

import Control.Monad.Eff (Eff())

import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)

import Signal (Signal(), constant, foldp, runSignal, sampleOn)
import Signal.Time (every, second)
import Signal.Channel (Chan(), Channel(), channel, send, subscribe)

import DOM (DOM())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import React
import React.DOM as D
import React.DOM.Props as P

type State a = { clicks :: Number
               , cps :: Number
               , clickBurst :: Number
               , upgradesBought :: Array Upgrade
               | a }
type GameState = State ()
type Environment = State ( channel :: Channel Action )

mkEnv :: Channel Action -> GameState -> Environment
mkEnv channel state = { clicks: state.clicks
                      , channel: channel
                      , clickBurst: state.clickBurst
                      , upgradesBought: state.upgradesBought
                      , cps: state.cps }

initialState :: GameState
initialState = { clicks: 0.0
               , cps: 0.0
               , upgradesBought: []
               , clickBurst: 1.0 }

data Action = Click
            | AutoClick
            | Reset
            | Buy Upgrade

data Upgrade = CPS Number
             | Burst Number

instance showUpgrade :: Show Upgrade where
  show (CPS n) = "buy CPS upgrade +" ++ show n
  show (Burst n) = "buy click upgrade +" ++ show n

genericButtonWithText :: Action -> String -> Environment -> ReactElement
genericButtonWithText act str env =
  D.button [P.onClick \ _ -> send env.channel act] [D.text str]

clicker :: Environment -> ReactElement
clicker = genericButtonWithText Click "click me!"

resetter :: Environment -> ReactElement
resetter = genericButtonWithText Reset "reset"

buyer :: Environment -> ReactElement
buyer env = D.div' $ [ upgrade (CPS 1.0), upgrade (Burst 1.0)] <*> [env]

upgrade :: Upgrade -> Environment -> ReactElement
upgrade up = genericButtonWithText (Buy up) (show up)

controls :: Environment -> ReactElement
controls env = D.div' $ [clicker, resetter, buyer] <*> [env]

currentClicks :: Environment -> ReactElement
currentClicks env = D.text (show env.clicks)

view :: Environment -> ReactElement
view env = D.div' $ [controls, currentClicks] <*> [env]

component :: Environment -> ReactClass Unit
component env = createClass (spec unit \ _ -> pure (view env))

step :: Action -> GameState -> GameState
step Click state = state { clicks = state.clicks + state.clickBurst }
step AutoClick state = state { clicks = state.clicks + state.cps }
step (Buy (CPS n)) state = state { cps = state.cps + n }
step (Buy (Burst n)) state = state { clickBurst = state.clickBurst + n }
step Reset _ = initialState

updateRate :: Signal Number
updateRate = every second

cps :: Signal Action
cps = sampleOn updateRate (constant AutoClick)

main :: forall eff. Eff ( chan :: Chan, dom :: DOM | eff ) Unit
main = do
  body' <- getBody
  channel <- channel Reset
  let actions = subscribe channel
      gameState = foldp step initialState (cps <> actions)
      game = gameState <#> mkEnv channel >>> (\ env -> render (ui env) body') >>> void
  runSignal game
  where
    ui env = D.div' [createFactory (component env) unit]
    getBody = do
      win <- window
      doc <- document win
      elm <- fromJust <$> toMaybe <$> body doc
      pure $ htmlElementToElement elm

module Main where

import Prelude

import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)

import Signal as S
import Signal.Time as S
import Signal.Channel as C

import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import React
import React.DOM as D
import React.DOM.Props as P

type State a = { clicks :: Number
               , cps :: Number
               , clickBurst :: Number
               | a }
type GameState = State ()
type Environment = State ( channel :: C.Channel Action )

data Action = Click
            | CPS
            | Reset
            | Buy Upgrade

data Upgrade = UpCPS Number
             | UpClick Number

mkEnv :: C.Channel Action -> GameState -> Environment
mkEnv channel state = { clicks: state.clicks
                      , channel: channel
                      , clickBurst: state.clickBurst
                      , cps: state.cps }

clicker :: Environment -> ReactElement
clicker env = D.button [P.onClick \ _ -> C.send env.channel Click] [D.text "click me!"]

resetter :: Environment -> ReactElement
resetter env = D.button [P.onClick \ _ -> C.send env.channel Reset] [D.text "reset"]

buyer :: Environment -> ReactElement
buyer env = D.div' [ D.button [P.onClick \ _ -> C.send env.channel (Buy (UpCPS 1.0))] [D.text "buy cps 1.0"]
                   , D.button [P.onClick \ _ -> C.send env.channel (Buy (UpClick 1.0))] [D.text "buy upclick 1.0"] ]

controls :: Environment -> ReactElement
controls env = D.div' $ [clicker, resetter, buyer] <*> [env]

currentClicks :: Environment -> ReactElement
currentClicks env = D.text (show env.clicks)

view :: Environment -> ReactElement
view env = D.div' $ [controls, currentClicks] <*> [env]

initialState :: GameState
initialState = { clicks: 0.0, cps: 0.0, clickBurst: 1.0 }

component :: Environment -> ReactClass Unit
component env = createClass (spec unit \ _ -> pure (view env))

step :: Action -> GameState -> GameState
step Click state = state { clicks = state.clicks + state.clickBurst }
step CPS state = state { clicks = state.clicks + state.cps }
step (Buy (UpCPS n)) state = state { cps = state.cps + n }
step (Buy (UpClick n)) state = state { clickBurst = state.clickBurst + n }
step Reset _ = initialState

updateRate :: S.Signal Number
updateRate = S.every S.second

cps :: S.Signal Action
cps = S.sampleOn updateRate (S.constant CPS)

main = do
  body' <- getBody
  channel <- C.channel Reset
  let actions = C.subscribe channel
      gameState = S.foldp step initialState (cps <> actions)
      game = gameState <#> mkEnv channel >>> (\ env -> render (ui env) body') >>> void
  S.runSignal game
  where
    ui env = D.div' [createFactory (component env) unit]
    getBody = do
      win <- window
      doc <- document win
      elm <- fromJust <$> toMaybe <$> body doc
      pure $ htmlElementToElement elm


Rename `updateMap` to `handleEvent`

Rename `updateMap` to `handleEvent`

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --panTo roadmap randomcoord
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> handleEvent x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  where
    handleEvent e mvcA polyline marker = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker result.coordinates
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker) coordinates

addToPath :: forall eff. (MVCArray LatLng) -> Polyline -> Marker -> Coordinate -> Eff eff Unit
addToPath mvcA polyline marker (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable (traverse_)
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)

  -- Various bits of test data to play with.
  --randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --panTo roadmap randomcoord
  --testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  --pushMVCArray mvcA testcoord
  --pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: startingPoint, map: roadmap, title: "HABP Location" })

  -- TODO: info window.
  --iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  --openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> updateMap x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  where
    updateMap e mvcA polyline marker = do
      --trace "RX from websocket"
      msgData <- getData e
      --trace msgData
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          --trace $ unsafeShowJSON result
          addToPath mvcA polyline marker result.coordinates
        Right (BeaconHistory coordinates) -> do
          --trace $ unsafeShowJSON coordinates
          traverse_ (addToPath mvcA polyline marker) coordinates

addToPath :: forall eff. (MVCArray LatLng) -> Polyline -> Marker -> Coordinate -> Eff eff Unit
addToPath mvcA polyline marker (Coordinate c) = do
  latestLatLng <- newLatLng c.latitude c.longitude
  pushMVCArray mvcA latestLatLng
  setPolylinePath polyline mvcA
  setMarkerPosition marker latestLatLng


Only evaluate exprs that are clicked on directly

Stop showing eval errors in the info box.

module Main where

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

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 Data.Either
import Data.Maybe
import Data.List
import Data.Tuple
import Data.StrMap as StrMap
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath, idExpr, makeDiv)
import Parser
import Evaluator (evalPath1, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
import AST
import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import JSHelpers
import TypeChecker (typeTreeProgramnEnv,buildTypeEnv,TypeEnv(),buildEmptyTypeTree,mapM, txToABC, prettyPrintTypeError,checkForError)
import Web (exprToJQuery, getPath)
import Parser (parseDefs, parseExpr)
import Evaluator (evalPath1, Env(),  defsToEnv)
import AST (Expr, TypeError(..),Path())
import JSHelpers (jqMap, isEnterKey, children, prepend)

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 eitherTyp = typeTreeProgramnEnv typEnv expr
            let typ' = either (\_ -> buildEmptyTypeTree typEnv expr) id eitherTyp
            let typ = txToABC typ'
            let idTree = idExpr expr
            void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }

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
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"
  typContainer <- liftEff $ prepareContainer "typ"
  svgContainer <- liftEff $ prepareContainer "svg"

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

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

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

  liftEff $ return unit :: DOMEff Unit

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Main where

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

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 Data.Either
import Data.Maybe
import Data.List
import Data.Tuple
import Data.StrMap as StrMap
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath, idExpr, makeDiv)
import Parser
import Evaluator (evalPath1, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
import AST
import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import JSHelpers
import TypeChecker (typeTreeProgramnEnv,buildTypeEnv,TypeEnv(),buildEmptyTypeTree,mapM, txToABC, prettyPrintTypeError,checkForError)
import Web (exprToJQuery, getPath)
import Parser (parseDefs, parseExpr)
import Evaluator (evalPath1, Env(),  defsToEnv)
import AST (Expr, TypeError(..),Path())
import JSHelpers (jqMap, isEnterKey, children, prepend)

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 eitherTyp = typeTreeProgramnEnv typEnv expr
            let typ' = either (\_ -> buildEmptyTypeTree typEnv expr) id eitherTyp
            let typ = txToABC typ'
            let idTree = idExpr expr
            void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }

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
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"
  typContainer <- liftEff $ prepareContainer "typ"
  svgContainer <- liftEff $ prepareContainer "svg"

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

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

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

  liftEff $ return unit :: DOMEff Unit

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, out = out, typEnv = typEnv} <- get
  let expr = out.expr
  liftEff $ print path
  case evalPath1 env path expr of
    Left msg    -> liftEff $ showInfo "execution" (show msg)
    Right expr' -> do
        let eitherTyp = typeTreeProgramnEnv typEnv expr'
        let typ'' = either (\_ -> buildEmptyTypeTree typEnv expr') id eitherTyp
        let typ' = txToABC typ''
        modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
        modify (\es -> es { history = out : es.history })
        showEvaluationState

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


use creds for cors

use creds for cors

module Ajax where

import Control.Monad.Eff

foreign import data JqAjax :: !
type EffJqAjax r = Eff (jqajax :: JqAjax | r)

foreign import jqAjax
  "function jqAjax(args) { \
  \ args.dataType = 'text'; \
  \ if(args.body) args.data = args.body; \
  \ args.type = args.method || 'GET'; \
  \ args.xhrFields = {withCredentials: true} \
  \ return function(cb) { \
  \   args.success = function(r){ return cb(r)(); }; \
  \   return function() { \
  \     $.ajax(args); \
  \    }\
  \  }\
  \}" :: forall a r eff. {|a} -> (String -> EffJqAjax r eff) -> (EffJqAjax r) Unit

module Ajax where

import Control.Monad.Eff

foreign import data JqAjax :: !
type EffJqAjax r = Eff (jqajax :: JqAjax | r)

foreign import jqAjax
  "function jqAjax(args) { \
  \ args.dataType = 'text'; \
  \ if(args.body) args.data = args.body; \
  \ args.type = args.method || 'GET'; \
  \ return function(cb) { \
  \   args.success = function(r){ return cb(r)(); }; \
  \   return function() { \
  \     $.ajax(args); \
  \    }\
  \  }\
  \}" :: forall a r eff. {|a} -> (String -> EffJqAjax r eff) -> (EffJqAjax r) Unit


Rename atomically to invulnerable

Rename atomically to invulnerable

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invulnerable
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Exception (Error, error, message) as Exports
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invulnerable ∷ ∀ eff a. Aff eff a → Aff eff a
invulnerable a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Exception (Error, error, message) as Exports
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Fix SD-1308 / Notebook routing regression

{-
Copyright 2015 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 Dashboard.Routing
  ( routing
  , routeSignal
  , Routes(..)
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Aff (Aff())

import Data.Either as E
import Data.Foldable as F
import Data.Functor.Eff as Eff
import Data.List as L
import Data.Maybe as M
import Data.Maybe.Unsafe as MU
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String.Regex as R
import Data.Map as Map
import Data.StrMap as SM
import Data.Tuple (Tuple(..))

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Routing.Match (Match())
import Routing.Match as Match
import Routing.Match.Class as Match

import Text.Parsing.Parser as P
import Utils.Path as UP

import Model.AccessType (AccessType(..), parseAccessType)
import Model.Notebook.Action (Action(..), parseAction, toAccessType)

import Notebook.Cell.CellId as CID
import Notebook.Cell.Port.VarMap as Port
import Notebook.Component as Notebook
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())

import Dashboard.Component as Dashboard
import Dashboard.Rename.Component as Rename

data Routes
  = CellRoute UP.DirPath CID.CellId AccessType Port.VarMap
  | ExploreRoute UP.FilePath
  | NotebookRoute UP.DirPath Action Port.VarMap

routing :: Match Routes
routing
  =   ExploreRoute <$> (oneSlash *> Match.lit "explore" *> explored)
  <|> CellRoute <$> notebook <*> (Match.lit "cells" *> cellId) <*> accessType <*> optionalVarMap
  <|> NotebookRoute <$> notebook <*> action <*> optionalVarMap

  where
  optionalVarMap :: Match Port.VarMap
  optionalVarMap = varMap <|> pure SM.empty

  varMap :: Match Port.VarMap
  varMap = Match.params <#> Map.toList >>> F.foldl go SM.empty
    where
      go m (Tuple k str) =
        case P.runParser str Port.parseVarMapValue of
          E.Left err -> m
          E.Right v -> SM.insert k v m

  oneSlash :: Match Unit
  oneSlash = Match.lit ""

  explored :: Match UP.FilePath
  explored = Match.eitherMatch $ mkResource <$> Match.list Match.str

  mkResource :: L.List String -> E.Either String UP.FilePath
  mkResource parts =
    case L.last parts of
      M.Just filename | filename /= "" ->
        let dirParts = MU.fromJust (L.init parts)
            filePart = P.file filename
            path = F.foldr (\part acc -> P.dir part </> acc) filePart dirParts
        in E.Right $ P.rootDir </> path
      _ -> E.Left "Expected non-empty explore path"

  notebook :: Match UP.DirPath
  notebook = notebookFromParts <$> partsAndName

  notebookFromParts :: Tuple (L.List String) String -> UP.DirPath
  notebookFromParts (Tuple ps nm) =
    F.foldl (</>) P.rootDir (map P.dir ps) </> P.dir nm

  partsAndName :: Match (Tuple (L.List String) String)
  partsAndName = Tuple <$> (oneSlash *> Match.list notName) <*> name

  name :: Match String
  name = Match.eitherMatch $ map notebookName Match.str

  notName :: Match String
  notName = Match.eitherMatch $ map pathPart Match.str

  notebookName :: String -> E.Either String String
  notebookName input
    | checkExtension input = E.Right input
    | otherwise = E.Left input

  pathPart :: String -> E.Either String String
  pathPart input
    | input == "" || checkExtension input = E.Left "incorrect path part"
    | otherwise = E.Right input

  extensionRegex :: R.Regex
  extensionRegex = R.regex ("\\." <> Config.notebookExtension <> "$") R.noFlags

  checkExtension :: String -> Boolean
  checkExtension = R.test extensionRegex

  action :: Match Action
  action = (Match.eitherMatch $ map parseAction Match.str) <|> pure (Load ReadOnly)

  accessType :: Match AccessType
  accessType = (Match.eitherMatch $ map parseAccessType Match.str) <|> pure ReadOnly

  cellId :: Match CID.CellId
  cellId = Match.eitherMatch $ map CID.stringToCellId Match.str

routeSignal :: Halogen.Driver Dashboard.QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  Tuple _ route <- Routing.matchesAff' UP.decodeURIPath routing
  case route of
    CellRoute res cellId accessType varMap -> notebook res (Load accessType) (M.Just cellId) varMap
    NotebookRoute res action varMap -> notebook res action M.Nothing varMap
    ExploreRoute res -> explore res

  where

  explore :: UP.FilePath -> Aff NotebookEffects Unit
  explore path = do
    fs <- Eff.liftEff detectBrowserFeatures
    driver $ Dashboard.toNotebook $ Notebook.ExploreFile fs path

  notebook :: UP.DirPath -> Action -> M.Maybe CID.CellId -> Port.VarMap -> Aff NotebookEffects Unit
  notebook path action viewing varMap = do
    let name = UP.getNameStr $ E.Right path
        directory = UP.getDir $ E.Right path
    currentPath <- driver $ Dashboard.fromNotebook Notebook.GetPath
    currentName <- driver $ Dashboard.fromNotebook Notebook.GetNameToSave
    currentVarMap <- driver $ Dashboard.fromNotebook Notebook.GetGlobalVarMap
    let pathChanged = currentPath /= pure directory
        nameChanged = currentName /= pure (P.DirName name)
        varMapChanged = currentVarMap /= varMap
    when (pathChanged || nameChanged) do
      features <- Eff.liftEff detectBrowserFeatures
      driver $ Dashboard.toRename $ Rename.SetText $ UP.dropNotebookExt name
      if action == New
        then driver $ Dashboard.toNotebook $ Notebook.Reset features path
        else driver $ Dashboard.toNotebook $ Notebook.LoadNotebook features path
      driver $ Dashboard.toDashboard $ Dashboard.SetAccessType $ toAccessType action
      driver $ Dashboard.toDashboard $ Dashboard.SetViewingCell viewing
      driver $ Dashboard.toNotebook $ Notebook.SetGlobalVarMap varMap

{-
Copyright 2015 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 Dashboard.Routing
  ( routing
  , routeSignal
  , Routes(..)
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Aff (Aff())

import Data.Either as E
import Data.Foldable as F
import Data.Functor.Eff as Eff
import Data.List as L
import Data.Maybe as M
import Data.Maybe.Unsafe as MU
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String.Regex as R
import Data.Map as Map
import Data.StrMap as SM
import Data.Tuple (Tuple(..))

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Routing.Match (Match())
import Routing.Match as Match
import Routing.Match.Class as Match

import Text.Parsing.Parser as P
import Utils.Path as UP

import Model.AccessType (AccessType(..), parseAccessType)
import Model.Notebook.Action (Action(..), parseAction, toAccessType)

import Notebook.Cell.CellId as CID
import Notebook.Cell.Port.VarMap as Port
import Notebook.Component as Notebook
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())

import Dashboard.Component as Dashboard
import Dashboard.Rename.Component as Rename

data Routes
  = CellRoute UP.DirPath CID.CellId AccessType Port.VarMap
  | ExploreRoute UP.FilePath
  | NotebookRoute UP.DirPath Action Port.VarMap

routing :: Match Routes
routing
  =   ExploreRoute <$> (oneSlash *> Match.lit "explore" *> explored)
  <|> CellRoute <$> notebook <*> (Match.lit "cells" *> cellId) <*> accessType <*> optionalVarMap
  <|> NotebookRoute <$> notebook <*> action <*> optionalVarMap

  where
  optionalVarMap :: Match Port.VarMap
  optionalVarMap = varMap <|> pure SM.empty

  varMap :: Match Port.VarMap
  varMap = Match.params <#> Map.toList >>> F.foldl go SM.empty
    where
      go m (Tuple k str) =
        case P.runParser str Port.parseVarMapValue of
          E.Left err -> m
          E.Right v -> SM.insert k v m

  oneSlash :: Match Unit
  oneSlash = Match.lit ""

  explored :: Match UP.FilePath
  explored = Match.eitherMatch $ mkResource <$> Match.list Match.str

  mkResource :: L.List String -> E.Either String UP.FilePath
  mkResource parts =
    case L.last parts of
      M.Just filename | filename /= "" ->
        let dirParts = MU.fromJust (L.init parts)
            filePart = P.file filename
            path = F.foldr (\part acc -> P.dir part </> acc) filePart dirParts
        in E.Right $ P.rootDir </> path
      _ -> E.Left "Expected non-empty explore path"

  notebook :: Match UP.DirPath
  notebook = notebookFromParts <$> partsAndName

  notebookFromParts :: Tuple (L.List String) String -> UP.DirPath
  notebookFromParts (Tuple ps nm) =
    F.foldl (</>) P.rootDir (map P.dir ps) </> P.dir nm

  partsAndName :: Match (Tuple (L.List String) String)
  partsAndName = Tuple <$> (oneSlash *> Match.list notName) <*> name

  name :: Match String
  name = Match.eitherMatch $ map notebookName Match.str

  notName :: Match String
  notName = Match.eitherMatch $ map pathPart Match.str

  notebookName :: String -> E.Either String String
  notebookName input
    | checkExtension input = E.Right input
    | otherwise = E.Left input

  pathPart :: String -> E.Either String String
  pathPart input
    | input == "" || checkExtension input = E.Left "incorrect path part"
    | otherwise = E.Right input

  extensionRegex :: R.Regex
  extensionRegex = R.regex ("\\." <> Config.notebookExtension <> "$") R.noFlags

  checkExtension :: String -> Boolean
  checkExtension = R.test extensionRegex

  action :: Match Action
  action = (Match.eitherMatch $ map parseAction Match.str) <|> pure (Load ReadOnly)

  accessType :: Match AccessType
  accessType = (Match.eitherMatch $ map parseAccessType Match.str) <|> pure ReadOnly

  cellId :: Match CID.CellId
  cellId = Match.eitherMatch $ map CID.stringToCellId Match.str

routeSignal :: Halogen.Driver Dashboard.QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  Tuple _ route <- Routing.matchesAff' UP.decodeURIPath routing
  case route of
    CellRoute res cellId accessType varMap -> notebook res (Load accessType) (M.Just cellId) varMap
    NotebookRoute res action varMap -> notebook res action M.Nothing varMap
    ExploreRoute res -> explore res

  where

  explore :: UP.FilePath -> Aff NotebookEffects Unit
  explore path = do
    fs <- Eff.liftEff detectBrowserFeatures
    driver $ Dashboard.toNotebook $ Notebook.ExploreFile fs path

  notebook :: UP.DirPath -> Action -> M.Maybe CID.CellId -> Port.VarMap -> Aff NotebookEffects Unit
  notebook path action viewing varMap = do
    let name = UP.getNameStr $ E.Right path
        directory = UP.getDir $ E.Right path
    currentPath <- driver $ Dashboard.fromNotebook Notebook.GetPath
    currentName <- driver $ Dashboard.fromNotebook Notebook.GetNameToSave
    currentVarMap <- driver $ Dashboard.fromNotebook Notebook.GetGlobalVarMap
    let pathChanged = currentPath /= pure directory
        nameChanged = currentName /= pure (P.DirName name)
        varMapChanged = currentVarMap /= varMap
    when (pathChanged || nameChanged) do
      features <- Eff.liftEff detectBrowserFeatures
      driver $ Dashboard.toRename $ Rename.SetText $ UP.dropNotebookExt name
      driver $ Dashboard.toNotebook $ Notebook.SetGlobalVarMap varMap
      if action == New
        then driver $ Dashboard.toNotebook $ Notebook.Reset features path
        else driver $ Dashboard.toNotebook $ Notebook.LoadNotebook features path
      driver $ Dashboard.toDashboard $ Dashboard.SetAccessType $ toAccessType action
      driver $ Dashboard.toDashboard $ Dashboard.SetViewingCell viewing