Remove stray console.log

Remove stray console.log

-- |
-- | Docopt utiltiy surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff(), launchAff, liftEff')
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Either (Either(..), either)
import Node.Path (FilePath())
import Control.Monad.Eff (Eff())
import Node.FS.Aff (readTextFile)
import Data.String (fromCharArray)
import Data.List (fromList)
import Data.Maybe (Maybe(..), maybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.Map (Map())
import Data.StrMap (StrMap())
import Data.StrMap as StrMap
import Data.Array (drop)
import Data.Array as A
import Data.Bifunctor (lmap)
import Data.Foldable (intercalate)
import Data.List.WordsLines (lines, unlines)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt (parseDocopt, applyDocopt)
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: forall e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |
type Options = {
  argv         :: Maybe Argv  -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env   -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean     -- ^ enable "option-first"
, dontExit     :: Boolean     -- ^ don't exit the process upon failure
}

defaultOptions :: Options
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
}

-- |
-- | Run docopt on the given docopt text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: forall e
     . String
    -> Options
    -> Eff (DocoptEff e) (StrMap D.Value)
run d o = do
  argv <- maybe (A.drop 2 <$> Process.argv) (return <<< id) o.argv
  env  <- maybe Process.getEnv              (return <<< id) o.env

  either onError return
         do
          { specification, usage } <- parseDocopt d
          lmap ((help usage) ++) do
            applyDocopt specification env argv o.optionsFirst

  where
    onError e = do
      if not o.dontExit
        then do
          Console.log e
          Process.exit 1
        else
          throwException $ error $ e

    help usage
      = "Usage:\n"
          ++ (unlines $ ("  " ++) <$> lines (dedent usage))
          ++ "\n"

-- |
-- | Docopt utiltiy surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff(), launchAff, liftEff')
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Either (Either(..), either)
import Node.Path (FilePath())
import Control.Monad.Eff (Eff())
import Node.FS.Aff (readTextFile)
import Data.String (fromCharArray)
import Data.List (fromList)
import Data.Maybe (Maybe(..), maybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.Map (Map())
import Data.StrMap (StrMap())
import Data.StrMap as StrMap
import Data.Array (drop)
import Data.Array as A
import Data.Bifunctor (lmap)
import Data.Foldable (intercalate)
import Data.List.WordsLines (lines, unlines)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt (parseDocopt, applyDocopt)
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: forall e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |
type Options = {
  argv         :: Maybe Argv  -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env   -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean     -- ^ enable "option-first"
, dontExit     :: Boolean     -- ^ don't exit the process upon failure
}

defaultOptions :: Options
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
}

-- |
-- | Run docopt on the given docopt text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: forall e
     . String
    -> Options
    -> Eff (DocoptEff e) (StrMap D.Value)
run d o = do
  argv <- maybe (A.drop 2 <$> Process.argv) (return <<< id) o.argv
  env  <- maybe Process.getEnv              (return <<< id) o.env

  Console.log (show o.dontExit)

  either onError return
         do
          { specification, usage } <- parseDocopt d
          lmap ((help usage) ++) do
            applyDocopt specification env argv o.optionsFirst

  where
    onError e = do
      if not o.dontExit
        then do
          Console.log e
          Process.exit 1
        else
          throwException $ error $ e

    help usage
      = "Usage:\n"
          ++ (unlines $ ("  " ++) <$> lines (dedent usage))
          ++ "\n"


Add type checking and code gen to the test

module Main where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Either

import Control.Apply
import Control.Monad.Identity

import Language.PureScript.Declarations
import Language.PureScript.Supply
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Environment
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS
import Language.PureScript.Supply

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

example =
  "module Test where\n\
  \\n\
  \  foo :: Number -> Number\n\
  \  foo 0 = 1\n\
  \  foo 1 = 0\n\
  \  foo n = n"

main = do
  trace "Lexing source file"
  case P.lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case P.runTokenParser (P.parseModule <* P.eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Desugaring module"
          case evalSupplyT 0 (desugar [mod]) of
            Left err -> print err
            Right [mod'@(Module mn ds exps)] -> do
              trace $ "Desugared: " ++ show mod'
              trace "Type checking and elaborating terms"
              case runCheck defaultOptions (typeCheckAll Nothing mn ds) of
                Left err -> print err
                Right (Tuple ds' env) -> do
                  trace $ "Elaborated: "++ show ds'
                  trace "Generating code"
                  case runIdentity (evalSupplyT 0 (moduleToJs CommonJS defaultOptions (Module mn ds' exps) env)) of
                    jss -> trace $ "Generated JS: " ++ show jss

module Main where

import Debug.Trace

import Data.Either

import Control.Apply

import Language.PureScript.Parser.Lexer
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Declarations

import Language.PureScript.Supply
import Language.PureScript.Sugar

example =
  "module Test where\n\
  \\n\
  \  foo :: Number -> Number\n\
  \  foo 0 = 1\n\
  \  foo 1 = 0\n\
  \  foo n = n"

main = do
  trace "Lexing source file"
  case lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case runTokenParser (parseModule <* eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Desugaring module"
          case evalSupplyT 0 (desugar [mod]) of
            Left err -> print err
            Right [mod'] -> do
              trace $ "Desugared: " ++ show mod'


Use joinWith rather than folding

Use joinWith rather than folding

module Controller.File.Item where

import Api.Fs (deleteItem, listing)
import Control.Inject1 (Inject1, inj)
import Control.Monad.Aff (makeAff, attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File.Common (open)
import Data.Array (filter)
import Data.DOM.Simple.Element (getElementById)
import Data.DOM.Simple.Window (document, globalWindow)
import Data.Either (Either(..))
import Data.Foldable (fold)
import Data.Maybe (Maybe(..))
import Data.String (joinWith)
import DOM (DOM())
import Driver.File (updatePath)
import EffectTypes (FileAppEff())
import Halogen.HTML.Events.Monad (Event(), async, andThen)
import Input.File (Input(), FileInput(SetDialog))
import Input.File.Item (ItemInput(..))
import Input.File.Rename (RenameInput(..))
import Model.File.Dialog (Dialog(..), initialRenameDialog)
import Model.File.Item (Item(), itemPath)
import Model.File.Resource (Resource(..))
import Routing.Hash (getHash, modifyHash)
import Utils (locationString, encodeURIComponent)
import qualified Control.UI.ZClipboard as Z

toInput :: forall m a b. (Applicative m, Inject1 a b) => a -> m b
toInput = pure <<< inj

handleDeleteItem :: forall e. Item -> Event (FileAppEff e) Input
handleDeleteItem item = async $ do
  deleteItem item
  toInput $ ItemRemove item

handleMoveItem :: forall e. Item -> Event (FileAppEff e) Input
handleMoveItem item = do
  (toInput $ SetDialog (Just (RenameDialog $ initialRenameDialog item)))
    `andThen` \_ -> do
    getDirectories "/"

handleOpenItem :: forall e. Item -> Event (FileAppEff e) Input
handleOpenItem item = do
  liftEff $ case item.resource of
    Directory -> moveDown item
    Database -> moveDown item
    File -> open item true
    Table -> open item true
    Notebook -> open item false
  empty

-- ATTENTION
-- This all should be moved to `initializer`
-- ATTENTION
handleShare :: forall e. Item -> Event (FileAppEff e) Input
handleShare item = async $ makeAff $ \_ k -> do
  url <- itemURL item
  k $ inj $ SetDialog (Just $ ShareDialog url)
  mbCopy <- document globalWindow >>= getElementById "copy-button"
  case mbCopy of
    Nothing -> pure unit
    Just btn -> void do
      Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

itemURL :: forall e. Item -> Eff (dom :: DOM | e) String
itemURL item = do
  loc <- locationString
  hash <- getHash
  let newUrl = loc <> case item.resource of
        File -> joinWith ""
             [Config.notebookUrl,
              "#", itemPath item,
              "/view",
              "/?q=", encodeURIComponent ("select * from ...")
             ]
        Notebook -> joinWith ""
             [Config.notebookUrl,
              "#", itemPath item,
              "/view"]
        _ -> "#" <> updatePath (item.root <> "/" <> item.name) hash
  pure $ newUrl

handleConfigure :: forall e. Item -> Event (FileAppEff e) Input
handleConfigure _ = toInput $ SetDialog (Just ConfigureDialog)

-- open dir or db
moveDown :: forall e. Item -> Eff (dom :: DOM | e) Unit
moveDown item = modifyHash $ updatePath (item.root <> "/" <> item.name <> "/")

getDirectories :: forall e. String -> Event (FileAppEff e) Input
getDirectories path = do
  ei <- liftAff $ attempt $ listing path
  case ei of
    Right items -> do
      let children = filter (\x -> x.resource == Directory ||
                                   x.resource == Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (toInput $ AddRenameDirs directories) `andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty

module Controller.File.Item where

import Api.Fs (deleteItem, listing)
import Control.Inject1 (Inject1, inj)
import Control.Monad.Aff (makeAff, attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File.Common (open)
import Data.Array (filter)
import Data.DOM.Simple.Element (getElementById)
import Data.DOM.Simple.Window (document, globalWindow)
import Data.Either (Either(..))
import Data.Foldable (fold, foldl)
import Data.Maybe (Maybe(..))
import DOM (DOM())
import Driver.File (updatePath)
import EffectTypes (FileAppEff())
import Halogen.HTML.Events.Monad (Event(), async, andThen)
import Input.File (Input(), FileInput(SetDialog))
import Input.File.Item (ItemInput(..))
import Input.File.Rename (RenameInput(..))
import Model.File.Dialog (Dialog(..), initialRenameDialog)
import Model.File.Item (Item(), itemPath)
import Model.File.Resource (Resource(..))
import Routing.Hash (getHash, modifyHash)
import Utils (locationString, encodeURIComponent)
import qualified Control.UI.ZClipboard as Z

toInput :: forall m a b. (Applicative m, Inject1 a b) => a -> m b
toInput = pure <<< inj

handleDeleteItem :: forall e. Item -> Event (FileAppEff e) Input
handleDeleteItem item = async $ do
  deleteItem item
  toInput $ ItemRemove item

handleMoveItem :: forall e. Item -> Event (FileAppEff e) Input
handleMoveItem item = do
  (toInput $ SetDialog (Just (RenameDialog $ initialRenameDialog item)))
    `andThen` \_ -> do
    getDirectories "/"

handleOpenItem :: forall e. Item -> Event (FileAppEff e) Input
handleOpenItem item = do
  liftEff $ case item.resource of
    Directory -> moveDown item
    Database -> moveDown item
    File -> open item true
    Table -> open item true
    Notebook -> open item false
  empty

-- ATTENTION
-- This all should be moved to `initializer`
-- ATTENTION
handleShare :: forall e. Item -> Event (FileAppEff e) Input
handleShare item = async $ makeAff $ \_ k -> do
  url <- itemURL item
  k $ inj $ SetDialog (Just $ ShareDialog url)
  mbCopy <- document globalWindow >>= getElementById "copy-button"
  case mbCopy of
    Nothing -> pure unit
    Just btn -> void do
      Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

itemURL :: forall e. Item -> Eff (dom :: DOM | e) String
itemURL item = do
  loc <- locationString
  hash <- getHash
  let newUrl = loc <> case item.resource of
        File -> foldl (<>) ""
             [Config.notebookUrl,
              "#", itemPath item,
              "/view",
              "/?q=", encodeURIComponent ("select * from ...")
             ]
        Notebook -> foldl (<>) ""
             [Config.notebookUrl,
              "#", itemPath item,
              "/view"]
        _ -> "#" <> updatePath (item.root <> "/" <> item.name) hash
  pure $ newUrl

handleConfigure :: forall e. Item -> Event (FileAppEff e) Input
handleConfigure _ = toInput $ SetDialog (Just ConfigureDialog)

-- open dir or db
moveDown :: forall e. Item -> Eff (dom :: DOM | e) Unit
moveDown item = modifyHash $ updatePath (item.root <> "/" <> item.name <> "/")

getDirectories :: forall e. String -> Event (FileAppEff e) Input
getDirectories path = do
  ei <- liftAff $ attempt $ listing path
  case ei of
    Right items -> do
      let children = filter (\x -> x.resource == Directory ||
                                   x.resource == Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (toInput $ AddRenameDirs directories) `andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty


Use the name interpret instead of render

module Main where

import Data.Array (concatMap)

import Control.Monad (foldM)
import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

lsystem :: forall a m s. (Monad m) =>
                         [a] ->
                         (a -> [a]) ->
		         (s -> a -> m s) ->
                         Number ->
		         s -> m s
lsystem init prod interpret n state = go init n
  where
  go s 0 = foldM interpret state s
  go s n = go (concatMap prod s) (n - 1)

data Alphabet = L | R | F

type Sentence = [Alphabet]

type State =
  { x :: Number
  , y :: Number
  , theta :: Number
  }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  let
    initial :: Sentence
    initial = [F, R, R, F, R, R, F, R, R]

    productions :: Alphabet -> Sentence
    productions L = [L]
    productions R = [R]
    productions F = [F, L, F, R, R, F, L, F]

    interpret :: State -> Alphabet -> Eff (canvas :: Canvas) State
    interpret state L = return $ state { theta = state.theta - Math.pi / 3 }
    interpret state R = return $ state { theta = state.theta + Math.pi / 3 }
    interpret state F = do
      let x' = state.x + Math.cos state.theta * 1.5
          y' = state.y + Math.sin state.theta * 1.5
      moveTo ctx state.x state.y
      lineTo ctx x' y'
      return { x: x', y: y', theta: state.theta }

    initialState :: State
    initialState = { x: 120, y: 200, theta: 0 }

  setStrokeStyle "#000000" ctx

  strokePath ctx $ lsystem initial productions interpret 5 initialState

module Main where

import Data.Array (concatMap)

import Control.Monad (foldM)
import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

lsystem :: forall a m s. (Monad m) =>
                         [a] ->
                         (a -> [a]) ->
		         (s -> a -> m s) ->
                         Number ->
		         s -> m s
lsystem init prod interpret n state = go init n
  where
  go s 0 = foldM interpret state s
  go s n = go (concatMap prod s) (n - 1)

data Alphabet = L | R | F

type Sentence = [Alphabet]

type State =
  { x :: Number
  , y :: Number
  , theta :: Number
  }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  let
    initial :: Sentence
    initial = [F, R, R, F, R, R, F, R, R]

    productions :: Alphabet -> Sentence
    productions L = [L]
    productions R = [R]
    productions F = [F, L, F, R, R, F, L, F]

    render :: State -> Alphabet -> Eff (canvas :: Canvas) State
    render state L = return $ state { theta = state.theta - Math.pi / 3 }
    render state R = return $ state { theta = state.theta + Math.pi / 3 }
    render state F = do
      let x' = state.x + Math.cos state.theta * 1.5
          y' = state.y + Math.sin state.theta * 1.5
      moveTo ctx state.x state.y
      lineTo ctx x' y'
      return { x: x', y: y', theta: state.theta }

    initialState :: State
    initialState = { x: 120, y: 200, theta: 0 }

  setStrokeStyle "#000000" ctx

  strokePath ctx $ lsystem initial productions render 5 initialState


ui handling of file deletion

ui handling of file deletion

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array (head, last, mapMaybe, filter)
import Data.Foldable as F
import Data.Functor.Coproduct.Nested (coproduct5)
import Data.Lens ((.~))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.String.Regex as Rgx

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Quasar.Data (QData(..))

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.Install (ChildQuery, ChildSlot, ChildState, QueryP, StateP, cpBreadcrumbs, cpDialog, cpListing, cpSearch, cpHeader, toDialog, toFs, toListing, toSearch)
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, _isMount, _path, _salt, _showHiddenFiles, _sort, _version, initialState)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo, viewInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Render.CSS as Rc
import SlamData.SignIn.Component as SignIn
import SlamData.Header.Component as Header

import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type DSL = H.ParentDSL State ChildState Query ChildQuery Slam ChildSlot

comp ∷ H.Component StateP QueryP Slam
comp = H.parentComponent { render, eval, peek: Just (peek ∘ H.runChildF) }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ Rc.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    [ HH.slot' cpHeader unit \_ →
          { component: Header.comp
          , initialState: H.parentState Header.initialState
          }

    , content
        [ HH.slot' cpSearch unit \_ →
             { component: Search.comp
             , initialState: Search.initialState
             }
        , HH.div_
            [ HH.slot' cpBreadcrumbs unit \_ →
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , HH.slot' cpListing unit \_ →
            { component: Listing.comp
            , initialState: H.parentState Listing.initialState
            }
        ]
    , HH.slot' cpDialog unit \_ →
        { component: Dialog.comp
        , initialState: H.parentState Dialog.initialState
        }
    ]

eval ∷ Query ~> DSL
eval (Resort next) = do
  { sort, salt, path } ← H.get
  searchValue ← H.query' cpSearch unit (H.request Search.GetValue)
  H.fromEff $ setLocation $ browseURL searchValue (notSort sort) salt path
  pure next
eval (SetPath path next) = H.modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  H.modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = H.modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = H.modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ true)
  queryListing $ H.action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ false)
  queryListing $ H.action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path ← H.gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path ← H.gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  result ← runExceptT do
    path ← lift $ H.gets _.path
    dirName ← ExceptT $ API.getNewName path Config.newFolderName
    let dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
    lift $ queryListing $ H.action (Listing.Add dirItem)
    ExceptT $ API.save hiddenFile jsonEmptyObject
    lift $ queryListing $ H.action (Listing.Filter (_ ≠ dirItem))
    pure dirRes
  case result of
    Left err →
      showDialog $ Dialog.Error
        $ "There was a problem creating the directory: "
        ⊕ message err
    Right dirRes →
      void $ queryListing $ H.action $ Listing.Add (Item dirRes)
  pure next

eval (MakeWorkspace next) = do
  path ← H.gets _.path
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      -- This error isn't strictly true as we're not actually creating the
      -- workspace here, but saying there was a problem "creating a name for the
      -- workspace" would be a little strange
      showDialog $ Dialog.Error
        $ "There was a problem creating the workspace: "
        ⊕ message err
    Right name' → do
      H.fromEff $ setLocation $ mkWorkspaceURL (path </> dir name') New
  pure next

eval (UploadFile el next) = do
  mbInput ← H.fromEff $ D.querySelector "input" el
  for_ mbInput \input →
    void $ H.fromEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr ← map Cf.fileListToArray $ (H.fromAff $ Cf.files el)
  H.fromEff $ clearValue el
  case head fileArr of
    Nothing →
      let err ∷ Slam Unit
          err = throwError $ error "empty filelist"
      in H.fromAff err
    Just f → uploadFileSelected f
  pure next

eval (Download next) = do
  path ← H.gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = H.modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.fromEff (Cf.name f)
      <#> Rgx.replace (Rgx.regex "/" Rgx.noFlags{global=true}) ":"
      >>= API.getNewName path

  case name of
    Left err → showDialog $ Dialog.Error (message err)
    Right name' → do
      reader ← H.fromEff Cf.newReaderEff
      content' ← H.fromAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      queryListing $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      case f' of
        Left err → do
          queryListing $ H.action $
            Listing.Filter (not ∘ eq (R.File fileName) ∘ itemResource)
          showDialog $ Dialog.Error (message err)
        Right _ → H.fromEff $ openItem res sort salt
  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in F.all isJust [S.stripPrefix "[" trimmed, S.stripSuffix "]" trimmed]

peek ∷ ∀ a. ChildQuery a → DSL Unit
peek =
  coproduct5
    listingPeek
    searchPeek
    (const (pure unit))
    dialogPeek
    (const (pure unit))

listingPeek ∷ ∀ a. Listing.QueryP a → DSL Unit
listingPeek = coproduct go (itemPeek ∘ H.runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek ∷ ∀ a. Item.Query a → DSL Unit
itemPeek (Item.Open res _) = do
  { sort, salt } ← H.get
  H.fromEff $ openItem res sort salt
itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x →
    void $ queryDialog Dialog.cpRename $ H.action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  -- Replace actual item with phantom
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
  queryListing $ H.action $ Listing.Add (PhantomItem res)
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← API.delete res
  -- Remove phantom resource after we have response from server
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)

  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ queryListing $ H.action $ Listing.Add (Item res)
      showDialog $ Dialog.Error (message err)
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ queryListing $ H.action $ Listing.Add (Item res')

  resort

itemPeek (Item.Share res _) = do
  { sort, salt } ← H.get
  loc ← H.fromEff locationString
  let url = loc ⊕ "/" ⊕ itemURL sort salt ReadOnly res
  showDialog (Dialog.Share url)
itemPeek (Item.Download res _) = download res
itemPeek (Item.SharePermissions res _) = do
  showDialog $ Dialog.Permissions res
itemPeek _ = pure unit

searchPeek ∷ ∀ a. Search.Query a → DSL Unit
searchPeek (Search.Clear _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  H.fromEff $ setLocation $ browseURL Nothing sort salt path
searchPeek (Search.Submit _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  value ← H.query' cpSearch unit $ H.request Search.GetValue
  H.fromEff $ setLocation $ browseURL value sort salt path
searchPeek _ = pure unit

dialogPeek ∷ ∀ a. Dialog.QueryP a → DSL Unit
dialogPeek = coproduct (const (pure unit)) (dialogChildrenPeek ∘ H.runChildF)

dialogChildrenPeek ∷ ∀ a. Dialog.ChildQuery a → DSL Unit
dialogChildrenPeek q =
  fromMaybe (pure unit) (mountPeek <$> prjQuery Dialog.cpMount q)

mountPeek ∷ ∀ a. Mount.QueryP a → DSL Unit
mountPeek = coproduct go (const (pure unit))
  where
  go ∷ Mount.Query a → DSL Unit
  go (Mount.NotifySave _) = do
    mount ← queryDialog Dialog.cpMount $ left (H.request Mount.Save)
    case join mount of
      Nothing → pure unit
      Just m → do
        hideDialog
        -- check if we just edited the mount for the current directory, as if
        -- so, we don't want to add an item to the list for it
        isCurrentMount ← case m of
          R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
          _ → pure false
        when (not isCurrentMount) do
          queryListing $ H.action $ Listing.Add $ Item (R.Mount m)
          resort
  go _ = pure unit

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu = querySignIn $ H.action SignIn.DismissSubmenu
  where
  querySignIn ∷ ∀ a. SignIn.Query a → DSL Unit
  querySignIn =
    void
      ∘ H.query' cpHeader unit
      ∘ right
      ∘ H.ChildF (injSlot Header.cpSignIn unit)
      ∘ right
      ∘ left

updateBreadcrumbs ∷ DSL Unit
updateBreadcrumbs = do
  { path, sort, salt } ← H.get
  void $ H.query' cpBreadcrumbs unit $ H.action (Breadcrumbs.Update path sort salt)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  mbIsSearching ← H.query' cpSearch unit (H.request Search.IsSearching)
  case mbIsSearching of
    Nothing → pure unit
    Just isSearching →
      void $ queryListing $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure (R.View path) = do
  viewInfo ← API.viewInfo path
  showDialog
    case viewInfo of
      Left err →
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ show err
      Right info →
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  viewInfo ← API.mountInfo path
  showDialog
    case viewInfo of
      Left err →
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ message err
      Right config →
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Left (MongoDB.fromConfig config)))

download ∷ R.Resource → DSL Unit
download res = do
  showDialog (Dialog.Download res)
  getChildren
    (const true)
    (void ∘ queryDialog Dialog.cpDownload ∘ H.action ∘ Download.AddSources)
    rootDir
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = filter pred items
          parents = mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren (R.isDirectory ∨ R.isDatabaseMount)

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' cpDialog unit ∘ left ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog = void $ H.query' cpDialog unit $ left (H.action Dialog.Dismiss)

queryListing ∷ ∀ a. Listing.Query a → DSL (Maybe a)
queryListing = H.query' cpListing unit ∘ left

queryItem ∷ ∀ a. Listing.ItemSlot → Item.Query a → DSL (Maybe a)
queryItem slot = H.query' cpListing unit ∘ right ∘ H.ChildF slot

queryDialog
  ∷ ∀ s f a
  . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  → f a
  → DSL (Maybe a)
queryDialog cp =
  H.query' cpDialog unit ∘ right ∘ H.ChildF (injSlot cp unit) ∘ injQuery cp

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array (head, last, mapMaybe, filter)
import Data.Foldable as F
import Data.Functor.Coproduct.Nested (coproduct5)
import Data.Lens ((.~))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.String.Regex as Rgx

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Quasar.Data (QData(..))

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.Install (ChildQuery, ChildSlot, ChildState, QueryP, StateP, cpBreadcrumbs, cpDialog, cpListing, cpSearch, cpHeader, toDialog, toFs, toListing, toSearch)
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, _isMount, _path, _salt, _showHiddenFiles, _sort, _version, initialState)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo, viewInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Render.CSS as Rc
import SlamData.SignIn.Component as SignIn
import SlamData.Header.Component as Header

import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type DSL = H.ParentDSL State ChildState Query ChildQuery Slam ChildSlot

comp ∷ H.Component StateP QueryP Slam
comp = H.parentComponent { render, eval, peek: Just (peek ∘ H.runChildF) }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ Rc.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    [ HH.slot' cpHeader unit \_ →
          { component: Header.comp
          , initialState: H.parentState Header.initialState
          }

    , content
        [ HH.slot' cpSearch unit \_ →
             { component: Search.comp
             , initialState: Search.initialState
             }
        , HH.div_
            [ HH.slot' cpBreadcrumbs unit \_ →
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , HH.slot' cpListing unit \_ →
            { component: Listing.comp
            , initialState: H.parentState Listing.initialState
            }
        ]
    , HH.slot' cpDialog unit \_ →
        { component: Dialog.comp
        , initialState: H.parentState Dialog.initialState
        }
    ]

eval ∷ Query ~> DSL
eval (Resort next) = do
  { sort, salt, path } ← H.get
  searchValue ← H.query' cpSearch unit (H.request Search.GetValue)
  H.fromEff $ setLocation $ browseURL searchValue (notSort sort) salt path
  pure next
eval (SetPath path next) = H.modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  H.modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = H.modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = H.modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ true)
  queryListing $ H.action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ false)
  queryListing $ H.action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path ← H.gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path ← H.gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  result ← runExceptT do
    path ← lift $ H.gets _.path
    dirName ← ExceptT $ API.getNewName path Config.newFolderName
    let dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
    lift $ queryListing $ H.action (Listing.Add dirItem)
    ExceptT $ API.save hiddenFile jsonEmptyObject
    lift $ queryListing $ H.action (Listing.Filter (_ ≠ dirItem))
    pure dirRes
  case result of
    Left err →
      showDialog $ Dialog.Error
        $ "There was a problem creating the directory: "
        ⊕ message err
    Right dirRes →
      void $ queryListing $ H.action $ Listing.Add (Item dirRes)
  pure next

eval (MakeWorkspace next) = do
  path ← H.gets _.path
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      -- This error isn't strictly true as we're not actually creating the
      -- workspace here, but saying there was a problem "creating a name for the
      -- workspace" would be a little strange
      showDialog $ Dialog.Error
        $ "There was a problem creating the workspace: "
        ⊕ message err
    Right name' → do
      H.fromEff $ setLocation $ mkWorkspaceURL (path </> dir name') New
  pure next

eval (UploadFile el next) = do
  mbInput ← H.fromEff $ D.querySelector "input" el
  for_ mbInput \input →
    void $ H.fromEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr ← map Cf.fileListToArray $ (H.fromAff $ Cf.files el)
  H.fromEff $ clearValue el
  case head fileArr of
    Nothing →
      let err ∷ Slam Unit
          err = throwError $ error "empty filelist"
      in H.fromAff err
    Just f → uploadFileSelected f
  pure next

eval (Download next) = do
  path ← H.gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = H.modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.fromEff (Cf.name f)
      <#> Rgx.replace (Rgx.regex "/" Rgx.noFlags{global=true}) ":"
      >>= API.getNewName path

  case name of
    Left err → showDialog $ Dialog.Error (message err)
    Right name' → do
      reader ← H.fromEff Cf.newReaderEff
      content' ← H.fromAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      queryListing $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      case f' of
        Left err → do
          queryListing $ H.action $
            Listing.Filter (not ∘ eq (R.File fileName) ∘ itemResource)
          showDialog $ Dialog.Error (message err)
        Right _ → H.fromEff $ openItem res sort salt
  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in F.all isJust [S.stripPrefix "[" trimmed, S.stripSuffix "]" trimmed]

peek ∷ ∀ a. ChildQuery a → DSL Unit
peek =
  coproduct5
    listingPeek
    searchPeek
    (const (pure unit))
    dialogPeek
    (const (pure unit))

listingPeek ∷ ∀ a. Listing.QueryP a → DSL Unit
listingPeek = coproduct go (itemPeek ∘ H.runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek ∷ ∀ a. Item.Query a → DSL Unit
itemPeek (Item.Open res _) = do
  { sort, salt } ← H.get
  H.fromEff $ openItem res sort salt
itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x →
    void $ queryDialog Dialog.cpRename $ H.action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  mbTrashFolder ← API.delete res
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
  case mbTrashFolder of
    Left err → showDialog $ Dialog.Error (message err)
    Right (Nothing) → pure unit
    Right (Just res') → void $ queryListing $ H.action $ Listing.Add (Item res')
itemPeek (Item.Share res _) = do
  { sort, salt } ← H.get
  loc ← H.fromEff locationString
  let url = loc ⊕ "/" ⊕ itemURL sort salt ReadOnly res
  showDialog (Dialog.Share url)
itemPeek (Item.Download res _) = download res
itemPeek (Item.SharePermissions res _) = do
  showDialog $ Dialog.Permissions res
itemPeek _ = pure unit

searchPeek ∷ ∀ a. Search.Query a → DSL Unit
searchPeek (Search.Clear _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  H.fromEff $ setLocation $ browseURL Nothing sort salt path
searchPeek (Search.Submit _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  value ← H.query' cpSearch unit $ H.request Search.GetValue
  H.fromEff $ setLocation $ browseURL value sort salt path
searchPeek _ = pure unit

dialogPeek ∷ ∀ a. Dialog.QueryP a → DSL Unit
dialogPeek = coproduct (const (pure unit)) (dialogChildrenPeek ∘ H.runChildF)

dialogChildrenPeek ∷ ∀ a. Dialog.ChildQuery a → DSL Unit
dialogChildrenPeek q =
  fromMaybe (pure unit) (mountPeek <$> prjQuery Dialog.cpMount q)

mountPeek ∷ ∀ a. Mount.QueryP a → DSL Unit
mountPeek = coproduct go (const (pure unit))
  where
  go ∷ Mount.Query a → DSL Unit
  go (Mount.NotifySave _) = do
    mount ← queryDialog Dialog.cpMount $ left (H.request Mount.Save)
    case join mount of
      Nothing → pure unit
      Just m → do
        hideDialog
        -- check if we just edited the mount for the current directory, as if
        -- so, we don't want to add an item to the list for it
        isCurrentMount ← case m of
          R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
          _ → pure false
        when (not isCurrentMount) do
          queryListing $ H.action $ Listing.Add $ Item (R.Mount m)
          resort
  go _ = pure unit

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu = querySignIn $ H.action SignIn.DismissSubmenu
  where
  querySignIn ∷ ∀ a. SignIn.Query a → DSL Unit
  querySignIn =
    void
      ∘ H.query' cpHeader unit
      ∘ right
      ∘ H.ChildF (injSlot Header.cpSignIn unit)
      ∘ right
      ∘ left

updateBreadcrumbs ∷ DSL Unit
updateBreadcrumbs = do
  { path, sort, salt } ← H.get
  void $ H.query' cpBreadcrumbs unit $ H.action (Breadcrumbs.Update path sort salt)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  mbIsSearching ← H.query' cpSearch unit (H.request Search.IsSearching)
  case mbIsSearching of
    Nothing → pure unit
    Just isSearching →
      void $ queryListing $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure (R.View path) = do
  viewInfo ← API.viewInfo path
  showDialog
    case viewInfo of
      Left err →
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ show err
      Right info →
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  viewInfo ← API.mountInfo path
  showDialog
    case viewInfo of
      Left err →
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ message err
      Right config →
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Left (MongoDB.fromConfig config)))

download ∷ R.Resource → DSL Unit
download res = do
  showDialog (Dialog.Download res)
  getChildren
    (const true)
    (void ∘ queryDialog Dialog.cpDownload ∘ H.action ∘ Download.AddSources)
    rootDir
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = filter pred items
          parents = mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren (R.isDirectory ∨ R.isDatabaseMount)

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' cpDialog unit ∘ left ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog = void $ H.query' cpDialog unit $ left (H.action Dialog.Dismiss)

queryListing ∷ ∀ a. Listing.Query a → DSL (Maybe a)
queryListing = H.query' cpListing unit ∘ left

queryItem ∷ ∀ a. Listing.ItemSlot → Item.Query a → DSL (Maybe a)
queryItem slot = H.query' cpListing unit ∘ right ∘ H.ChildF slot

queryDialog
  ∷ ∀ s f a
  . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  → f a
  → DSL (Maybe a)
queryDialog cp =
  H.query' cpDialog unit ∘ right ∘ H.ChildF (injSlot cp unit) ∘ injQuery cp


end rampages after the given number of steps

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 300

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap excludes bigDots
  , countdown: Just 90
  , rampage: Nothing
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  excludes = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \(Tuple pId counter) ->
    changeRampage (Tuple pId <$> decrementOrNothing counter)

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
-- * put a big dot in every given space
makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap excludes bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos excludes) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 300

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap excludes bigDots
  , countdown: Just 90
  , rampage: Nothing
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  excludes = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  whenJust (lookupItemByPosition (p ^. pPosition) g) $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: Player -> Direction -> GameUpdateM Boolean
canMoveInDirection (Player p) d =
  let newPosition = moveInDirection d p.position
      canMove game = isFree game.map newPosition
  in  canMove <$> getGame

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

-- Prepare items on a map
-- * put a little dot in every free space
-- * put a big dot in every given space
makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap excludes bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos excludes) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x


Remove accidental text inside <select>

Remove accidental text inside <select>

module Main (main) where

import Prelude
import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _ = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> (List Wall) -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active = foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel ->
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else ""
    withElementById "message" doc (setInnerHTML message)
    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- DEBUG:
    log $ "Program: " ++ show tids
    log $ "Initial: " ++ show level.initial
    log "Steps:"
    traverse_ print steps
    log "---"
    log $ "Target: " ++ show level.target
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> do
                   ctrlPressed <- ctrlKey event
                   when (not ctrlPressed) resetLevel
         _ -> return unit
    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, console :: CONSOLE, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "0.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, console :: CONSOLE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- toList <$> traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addMouseEventListener MouseClickEvent (const resetLevel :: DOMEvent -> _) button

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (main) where

import Prelude
import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _ = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> (List Wall) -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active = foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "levels" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else ""
    withElementById "message" doc (setInnerHTML message)
    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- DEBUG:
    log $ "Program: " ++ show tids
    log $ "Initial: " ++ show level.initial
    log "Steps:"
    traverse_ print steps
    log "---"
    log $ "Target: " ++ show level.target
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> do
                   ctrlPressed <- ctrlKey event
                   when (not ctrlPressed) resetLevel
         _ -> return unit
    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, console :: CONSOLE, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "0.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, console :: CONSOLE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- toList <$> traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addMouseEventListener MouseClickEvent (const resetLevel :: DOMEvent -> _) button

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs