Remove unnecessary import of fromJust

Remove unnecessary import of fromJust

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  , FileDescriptor(..)
  , FileFlags(..)
  , BufferLength(..)
  , BufferOffset(..)
  , ByteCount(..)
  , FileMode(..)
  , FilePosition(..)
  , fdOpen
  , fdRead
  , fdNext
  , fdWrite
  , fdAppend
  , fdFlush
  , fdClose
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Either
import Data.Function
import Data.Maybe (Maybe(..))
import Node.Buffer (Buffer(..), size)
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms

foreign import data FileDescriptor :: *

data FileFlags = R | R_PLUS | RS | RS_PLUS
               | W | WX | W_PLUS | WX_PLUS
               | A | AX | A_PLUS | AX_PLUS

type BufferLength = Number
type BufferOffset = Number
type ByteCount = Number
type FileMode = Number
type FilePosition = Number

foreign import fs "var fs = require('fs');" ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Number Unit
  , chownSync :: Fn3 FilePath Number Number Unit
  , chmodSync :: Fn2 FilePath String Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath String Unit
  , readdirSync :: Fn1 FilePath [FilePath]
  , utimesSync :: Fn3 FilePath Number Number Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: FilePath -> Boolean
  , openSync :: Fn2 FilePath String FileDescriptor
  , readSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength FilePosition ByteCount
  , writeSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength FilePosition ByteCount
  , fsyncSync :: Fn1 FileDescriptor Unit
  , closeSync :: Fn1 FileDescriptor Unit
  }

foreign import createSync
  """
  var fs = require('fs');
  function createSync(file, flags, mode) {
    return fs.openSync(file, flags, mode);
  }
  """
  :: Fn3 FilePath String FileMode FileDescriptor

foreign import writeSeqSync
  """
  var fs = require('fs');
  function writeSeqSync(fd, buffer, offset, len) {
    return fs.writeSync(fd, buffer, offset, len);
  }
  """
  :: Fn4 FileDescriptor Buffer BufferOffset BufferLength ByteCount

foreign import readSeqSync
  """
  var fs = require('fs');
  function readSeqSync(fd, buffer, offset, len) {
    return fs.readSync(fd, buffer, offset, len);
  }
  """
  :: Fn4 FileDescriptor Buffer BufferOffset BufferLength ByteCount

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a)
                    -> Eff eff a

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Eff (fs :: FS, err :: Exception | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Perms
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chmod file perms = mkEff $ \_ -> runFn2
  fs.chmodSync file (permsToString perms)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Stats

stat file = return $ Stats $ runFn1
  fs.statSync file

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: Exception | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (show ty)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir = flip mkdir' $ mkPerms (r <> w <> x) (r <> w <> x) (r <> w <> x)

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir' file perms = mkEff $ \_ -> runFn2
  fs.mkdirSync file (permsToString perms)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: Exception | eff) [FilePath]

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                (ms (toEpochMilliseconds atime) / 1000)
                (ms (toEpochMilliseconds mtime) / 1000)
  where
  ms (Milliseconds n) = n

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: Exception | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (fs :: FS, err :: Exception | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: Exception | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (fs :: FS, err :: Exception | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: Exception | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = mkEff $ \_ -> fs.existsSync file

{- Synchronous File Descriptor Functions -}

--|
-- Open a file synchronously.  See Node
-- Documentation for details.
--
fdOpen :: forall opts eff.
          FilePath
       -> FileFlags
       -> Maybe FileMode
       -> Eff (err :: Exception, fs :: FS | eff) FileDescriptor
fdOpen file flags mode =
  case mode of
    Nothing  -> mkEff $ \_ -> runFn2 fs.openSync file (toStr flags)
    (Just m) -> mkEff $ \_ -> runFn3 createSync file (toStr flags) m
  where
    toStr R       = "r"
    toStr R_PLUS  = "r+"
    toStr RS      = "rs"
    toStr RS_PLUS = "rs+"
    toStr W       = "w"
    toStr WX      = "wx"
    toStr W_PLUS  = "w+"
    toStr WX_PLUS = "wx+"
    toStr A       = "a"
    toStr AX      = "ax"
    toStr A_PLUS  = "a+"
    toStr AX_PLUS = "ax+"

--|
-- Read to a file synchronously.  See Node
-- ocumentation for details.
--
fdRead :: forall eff.
          FileDescriptor
       -> Buffer
       -> BufferOffset
       -> BufferLength
       -> Maybe FilePosition
       -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdRead fd buff off len Nothing =
  mkEff $ \_ -> runFn4 readSeqSync fd buff off len
fdRead fd buff off len (Just pos) =
  mkEff $ \_ -> runFn5 fs.readSync fd buff off len pos

--|
-- Convienence function to fill the whole buffer from the current
-- file position.
--
fdNext :: forall eff.
          FileDescriptor
       -> Buffer
       -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdNext fd buff = fdRead fd buff 0 (size buff) Nothing

--|
-- Write to a file synchronously.  See Node
-- Documentation for details.
--
fdWrite :: forall eff.
           FileDescriptor
        -> Buffer
        -> BufferOffset
        -> BufferLength
        -> Maybe FilePosition
        -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdWrite fd buff off len Nothing =
  mkEff $ \_ -> runFn4 writeSeqSync fd buff off len
fdWrite fd buff off len (Just pos) =
  mkEff $ \_ -> runFn5 fs.writeSync fd buff off len pos

--|
-- Convienence function to append the whole buffer to the current
-- file position.
--
fdAppend :: forall eff.
            FileDescriptor
         -> Buffer
         -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdAppend fd buff = fdWrite fd buff 0 (size buff) Nothing

--|
-- Flush a file synchronously.  See Node
-- Documentation for details.
--
fdFlush :: forall eff.
           FileDescriptor
        -> Eff (err :: Exception, fs :: FS | eff) Unit
fdFlush fd = mkEff $ \_ -> runFn1 fs.fsyncSync fd

--|
-- Close a file synchronously.  See Node
-- Documentation for details.
--
fdClose :: forall eff.
           FileDescriptor
        -> Eff (err :: Exception, fs :: FS | eff) Unit
fdClose fd = mkEff $ \_ -> runFn1 fs.closeSync fd

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  , FileDescriptor(..)
  , FileFlags(..)
  , BufferLength(..)
  , BufferOffset(..)
  , ByteCount(..)
  , FileMode(..)
  , FilePosition(..)
  , fdOpen
  , fdRead
  , fdNext
  , fdWrite
  , fdAppend
  , fdFlush
  , fdClose
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Either
import Data.Function
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe(fromJust)
import Node.Buffer (Buffer(..), size)
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms

foreign import data FileDescriptor :: *

data FileFlags = R | R_PLUS | RS | RS_PLUS
               | W | WX | W_PLUS | WX_PLUS
               | A | AX | A_PLUS | AX_PLUS

type BufferLength = Number
type BufferOffset = Number
type ByteCount = Number
type FileMode = Number
type FilePosition = Number

foreign import fs "var fs = require('fs');" ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Number Unit
  , chownSync :: Fn3 FilePath Number Number Unit
  , chmodSync :: Fn2 FilePath String Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath String Unit
  , readdirSync :: Fn1 FilePath [FilePath]
  , utimesSync :: Fn3 FilePath Number Number Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: FilePath -> Boolean
  , openSync :: Fn2 FilePath String FileDescriptor
  , readSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength FilePosition ByteCount
  , writeSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength FilePosition ByteCount
  , fsyncSync :: Fn1 FileDescriptor Unit
  , closeSync :: Fn1 FileDescriptor Unit
  }

foreign import createSync
  """
  var fs = require('fs');
  function createSync(file, flags, mode) {
    return fs.openSync(file, flags, mode);
  }
  """
  :: Fn3 FilePath String FileMode FileDescriptor

foreign import writeSeqSync
  """
  var fs = require('fs');
  function writeSeqSync(fd, buffer, offset, len) {
    return fs.writeSync(fd, buffer, offset, len);
  }
  """
  :: Fn4 FileDescriptor Buffer BufferOffset BufferLength ByteCount

foreign import readSeqSync
  """
  var fs = require('fs');
  function readSeqSync(fd, buffer, offset, len) {
    return fs.readSync(fd, buffer, offset, len);
  }
  """
  :: Fn4 FileDescriptor Buffer BufferOffset BufferLength ByteCount

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a)
                    -> Eff eff a

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Eff (fs :: FS, err :: Exception | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Perms
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chmod file perms = mkEff $ \_ -> runFn2
  fs.chmodSync file (permsToString perms)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Stats

stat file = return $ Stats $ runFn1
  fs.statSync file

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: Exception | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (show ty)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir = flip mkdir' $ mkPerms (r <> w <> x) (r <> w <> x) (r <> w <> x)

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir' file perms = mkEff $ \_ -> runFn2
  fs.mkdirSync file (permsToString perms)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: Exception | eff) [FilePath]

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                (ms (toEpochMilliseconds atime) / 1000)
                (ms (toEpochMilliseconds mtime) / 1000)
  where
  ms (Milliseconds n) = n

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: Exception | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (fs :: FS, err :: Exception | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: Exception | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (fs :: FS, err :: Exception | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: Exception | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = mkEff $ \_ -> fs.existsSync file

{- Synchronous File Descriptor Functions -}

--|
-- Open a file synchronously.  See Node
-- Documentation for details.
--
fdOpen :: forall opts eff.
          FilePath
       -> FileFlags
       -> Maybe FileMode
       -> Eff (err :: Exception, fs :: FS | eff) FileDescriptor
fdOpen file flags mode =
  case mode of
    Nothing  -> mkEff $ \_ -> runFn2 fs.openSync file (toStr flags)
    (Just m) -> mkEff $ \_ -> runFn3 createSync file (toStr flags) m
  where
    toStr R       = "r"
    toStr R_PLUS  = "r+"
    toStr RS      = "rs"
    toStr RS_PLUS = "rs+"
    toStr W       = "w"
    toStr WX      = "wx"
    toStr W_PLUS  = "w+"
    toStr WX_PLUS = "wx+"
    toStr A       = "a"
    toStr AX      = "ax"
    toStr A_PLUS  = "a+"
    toStr AX_PLUS = "ax+"

--|
-- Read to a file synchronously.  See Node
-- ocumentation for details.
--
fdRead :: forall eff.
          FileDescriptor
       -> Buffer
       -> BufferOffset
       -> BufferLength
       -> Maybe FilePosition
       -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdRead fd buff off len Nothing =
  mkEff $ \_ -> runFn4 readSeqSync fd buff off len
fdRead fd buff off len (Just pos) =
  mkEff $ \_ -> runFn5 fs.readSync fd buff off len pos

--|
-- Convienence function to fill the whole buffer from the current
-- file position.
--
fdNext :: forall eff.
          FileDescriptor
       -> Buffer
       -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdNext fd buff = fdRead fd buff 0 (size buff) Nothing

--|
-- Write to a file synchronously.  See Node
-- Documentation for details.
--
fdWrite :: forall eff.
           FileDescriptor
        -> Buffer
        -> BufferOffset
        -> BufferLength
        -> Maybe FilePosition
        -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdWrite fd buff off len Nothing =
  mkEff $ \_ -> runFn4 writeSeqSync fd buff off len
fdWrite fd buff off len (Just pos) =
  mkEff $ \_ -> runFn5 fs.writeSync fd buff off len pos

--|
-- Convienence function to append the whole buffer to the current
-- file position.
--
fdAppend :: forall eff.
            FileDescriptor
         -> Buffer
         -> Eff (err :: Exception, fs :: FS | eff) ByteCount
fdAppend fd buff = fdWrite fd buff 0 (size buff) Nothing

--|
-- Flush a file synchronously.  See Node
-- Documentation for details.
--
fdFlush :: forall eff.
           FileDescriptor
        -> Eff (err :: Exception, fs :: FS | eff) Unit
fdFlush fd = mkEff $ \_ -> runFn1 fs.fsyncSync fd

--|
-- Close a file synchronously.  See Node
-- Documentation for details.
--
fdClose :: forall eff.
           FileDescriptor
        -> Eff (err :: Exception, fs :: FS | eff) Unit
fdClose fd = mkEff $ \_ -> runFn1 fs.closeSync fd


Removed unnecessary exports

Removed unnecessary exports

module Flag.Core (view, foldp, init) where

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), State, Event(..))
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (ajax ∷ AJAX | e) (Maybe Event)
fetch = do
  response <- attempt $ get "/countries.json"
  let countries = either (Left <<< show) decode response
  pure $ Just $ Receive $ case shuffle <$> countries of
    Left _   → Nothing
    Right xs → Just xs

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Respond name)      state = noEffects $ state { countries = Nothing, correct = state.correct + 1 }
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Request)           state = { state, effects: [fetch] }

view ∷ State → HTML Event
view state = div ! className "flagship" $ case state.countries of
  Nothing → toolbar state
  Just _  → toolbar state <> country state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button #! onClick (const Request) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    -- where isDisabled = state.countries >>= \xs → pure $ if (length xs == 0) then "" else "disabled"

country ∷ State → HTML Event
country state = div ! className "prompt" $ do
  case state.countries of
    Nothing        → button #! onClick (const Request) $ text "Start"
    Just _         → button $ text "Test"
    -- Just countries → liftEff $ countries >>= \countries -> case head countries of
    --   Nothing              → pure $ div $ text "All done!"
    --   Just (Country model) → pure $ do
    --     img ! src ("images/flags/" <> model.flag) ! alt "Flag"
    --     ul ! className "countries" $ for_ (take 4 countries) $ answer

answer ∷ Country → HTML Event
answer (Country model) =
  li $ button #! onClick (const $ Respond model.name) $ text model.name

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), State, Event(..))
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (ajax ∷ AJAX | e) (Maybe Event)
fetch = do
  response <- attempt $ get "/countries.json"
  let countries = either (Left <<< show) decode response
  pure $ Just $ Receive $ case shuffle <$> countries of
    Left _   → Nothing
    Right xs → Just xs

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Respond name)      state = noEffects $ state { countries = Nothing, correct = state.correct + 1 }
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Request)           state = { state, effects: [fetch] }

view ∷ State → HTML Event
view state = div ! className "flagship" $ case state.countries of
  Nothing → toolbar state
  Just _  → toolbar state <> country state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button #! onClick (const Request) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    -- where isDisabled = state.countries >>= \xs → pure $ if (length xs == 0) then "" else "disabled"

country ∷ State → HTML Event
country state = div ! className "prompt" $ do
  case state.countries of
    Nothing        → button #! onClick (const Request) $ text "Start"
    Just _         → button $ text "Test"
    -- Just countries → liftEff $ countries >>= \countries -> case head countries of
    --   Nothing              → pure $ div $ text "All done!"
    --   Just (Country model) → pure $ do
    --     img ! src ("images/flags/" <> model.flag) ! alt "Flag"
    --     ul ! className "countries" $ for_ (take 4 countries) $ answer

answer ∷ Country → HTML Event
answer (Country model) =
  li $ button #! onClick (const $ Respond model.name) $ text model.name


shorter rampages

shorter rampages

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.Arrow
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 = 180

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- 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
    (ChangedIsEaten x) -> pIsEaten .~ x

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)

changeIsEaten :: PlayerId -> Boolean -> GameUpdateM Unit
changeIsEaten pId x =
  applyGameUpdateM (GUPU pId (ChangedIsEaten x))

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 safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  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})
    ]
  safeZone = 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
      eachPlayer eatOtherPlayers
      eachPlayer unEatSelf
      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 pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId =
  (\g -> maybe false (fst >>> (==) pId) g.rampage) <$> getGame

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  when (not (p ^. pIsEaten)) $ do
    let mItem = lookupItemByPosition (p ^. pPosition) g
    whenJust mItem $ \(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

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeIsEaten pId' true
          changeScore pId $ p ^. pScore + p' ^. pScore
          changeScore pId' 0

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 pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId (Player p) d =
  let newPosition = moveInDirection d p.position
      destIsFree game  = isFree game.map newPosition
      immobilised game = not p.isEaten && isFleeing game
      isFleeing game   = maybe false (\(Tuple pId' count) ->
                                pId' /= pId && isOdd count) game.rampage
      both (Tuple x y) = x && y
  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

unEatSelf :: PlayerId -> Player -> GameUpdateM Unit
unEatSelf pId p = do
  g <- getGame
  when (p ^. pIsEaten && inSafeZone g (p ^. pPosition)) $ do
    changeIsEaten pId false

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

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

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone 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 safeZone) &&
      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.Arrow
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 = 240

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- 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
    (ChangedIsEaten x) -> pIsEaten .~ x

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)

changeIsEaten :: PlayerId -> Boolean -> GameUpdateM Unit
changeIsEaten pId x =
  applyGameUpdateM (GUPU pId (ChangedIsEaten x))

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 safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  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})
    ]
  safeZone = 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
      eachPlayer eatOtherPlayers
      eachPlayer unEatSelf
      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 pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId =
  (\g -> maybe false (fst >>> (==) pId) g.rampage) <$> getGame

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  when (not (p ^. pIsEaten)) $ do
    let mItem = lookupItemByPosition (p ^. pPosition) g
    whenJust mItem $ \(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

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeIsEaten pId' true
          changeScore pId $ p ^. pScore + p' ^. pScore
          changeScore pId' 0

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 pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId (Player p) d =
  let newPosition = moveInDirection d p.position
      destIsFree game  = isFree game.map newPosition
      immobilised game = not p.isEaten && isFleeing game
      isFleeing game   = maybe false (\(Tuple pId' count) ->
                                pId' /= pId && isOdd count) game.rampage
      both (Tuple x y) = x && y
  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

unEatSelf :: PlayerId -> Player -> GameUpdateM Unit
unEatSelf pId p = do
  g <- getGame
  when (p ^. pIsEaten && inSafeZone g (p ^. pPosition)) $ do
    changeIsEaten pId false

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

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

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone 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 safeZone) &&
      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


dont need this fundep

dont need this fundep

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Record (get)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (EXPRESS, ExpressM, Request, Response)
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Type.Prelude (class RowToList, RLProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => GetFiles (Aff e) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => GetWatched (Aff e) where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => GetIcons (Aff e) where
  getIconsData {db} _ = do
    _ <- liftAff <<< liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => UpdateWatched (Aff e) where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => OpenFile (Aff e) where
  openFile {dir} (OpenRequest or) = do
    _ <- liftAff $ case platform of
          Just Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => RemoveFile (Aff e) where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

registerRoutes :: forall routes handlers routesL handlersL m
   . RowToList routes routesL
  => RowToList handlers handlersL
  => Monad m
  => RoutesHandlers routesL handlersL routes handlers m
  => Record routes
  -> Record handlers
  -> m Unit
registerRoutes routes handlers =
  registerRoutesImpl
    (RLProxy :: RLProxy routesL)
    (RLProxy :: RLProxy handlersL)
    routes
    handlers

class RoutesHandlers
  (routesL :: RowList)
  (handlersL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  m
  where
    registerRoutesImpl :: forall proxy
       . Monad m
      => proxy routesL
      -> proxy handlersL
      -> Record routes
      -> Record handlers
      -> m Unit

instance routesHandlersNil :: RoutesHandlers Nil Nil trash1 trash2 m where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers rTail hTail routes handlers m
  , IsSymbol name
  , RowCons name handler trash1 handlers
  , RowCons name route trash2 routes
  , RegisterHandler route handler m
  ) => RoutesHandlers (Cons name route rTail) (Cons name handler hTail) routes handlers m where
  registerRoutesImpl _ _ routes handlers = do
    registerHandlerImpl (get nameP routes) (get nameP handlers)
    registerRoutesImpl (RLProxy :: RLProxy rTail) (RLProxy :: RLProxy hTail) routes handlers
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler m
  | route -> handler m
  where
    registerHandlerImpl :: route -> handler -> m Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.post route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        body <- getBody
        case runExcept (read body) of
          Right (r :: req) -> do
            response <- liftAff $ handler r
            sendJson $ write response
          Left e -> do
            setStatus 400
            sendJson $ write {error: show e}

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.get route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        response <- liftAff handler
        sendJson $ write response

routes :: forall e
   . Config
  -> App
       ( fs :: FS
       , db :: DBEffects
       , cp :: CHILD_PROCESS
       | e
       )
routes config = do
  useExternal jsonBodyParser
  registerRoutes
    apiRoutes
    { files: getFiles config
    , watched: getWatchedData config
    , getIcons: getIconsData config
    , update: updateWatched config
    , open: openFile config
    , remove: removeFile config
    }
  use $ static "dist"

main :: forall e
   . Eff
       ( console :: CONSOLE
       , db :: DBEffects
       , process :: PROCESS
       , cp :: CHILD_PROCESS
       , express :: EXPRESS
       , fs :: FS
       | e
       )
 Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Record (get)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (EXPRESS, ExpressM, Request, Response)
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Type.Prelude (class RowToList, RLProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => GetFiles (Aff e) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => GetWatched (Aff e) where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => GetIcons (Aff e) where
  getIconsData {db} _ = do
    _ <- liftAff <<< liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => UpdateWatched (Aff e) where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => OpenFile (Aff e) where
  openFile {dir} (OpenRequest or) = do
    _ <- liftAff $ case platform of
          Just Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => RemoveFile (Aff e) where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

registerRoutes :: forall proxy routes handlers routesL handlersL m
   . RowToList routes routesL
  => RowToList handlers handlersL
  => Monad m
  => RoutesHandlers routesL handlersL routes handlers m
  => Record routes
  -> Record handlers
  -> m Unit
registerRoutes routes handlers =
  registerRoutesImpl
    (RLProxy :: RLProxy routesL)
    (RLProxy :: RLProxy handlersL)
    routes
    handlers

class RoutesHandlers
  (routesL :: RowList)
  (handlersL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  m
  | routesL -> handlersL handlers m
  where
    registerRoutesImpl :: forall proxy
       . Monad m
      => proxy routesL
      -> proxy handlersL
      -> Record routes
      -> Record handlers
      -> m Unit

instance routesHandlersNil :: RoutesHandlers Nil Nil trash1 trash2 m where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers rTail hTail routes handlers m
  , IsSymbol name
  , RowCons name handler trash1 handlers
  , RowCons name route trash2 routes
  , RegisterHandler route handler m
  ) => RoutesHandlers (Cons name route rTail) (Cons name handler hTail) routes handlers m where
  registerRoutesImpl _ _ routes handlers = do
    registerHandlerImpl (get nameP routes) (get nameP handlers)
    registerRoutesImpl (RLProxy :: RLProxy rTail) (RLProxy :: RLProxy hTail) routes handlers
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler m
  | route -> handler m
  where
    registerHandlerImpl :: route -> handler -> m Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.post route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        body <- getBody
        case runExcept (read body) of
          Right (r :: req) -> do
            response <- liftAff $ handler r
            sendJson $ write response
          Left e -> do
            setStatus 400
            sendJson $ write {error: show e}

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.get route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        response <- liftAff handler
        sendJson $ write response

routes :: forall e
   . Config
  -> App
       ( fs :: FS
       , db :: DBEffects
       , cp :: CHILD_PROCESS
       | e
       )
routes config = do
  useExternal jsonBodyParser
  registerRoutes
    apiRoutes
    { files: getFiles config
    , watched: getWatchedData config
    , getIcons: getIconsData config
    , update: updateWatched config
    , open: openFile config
    , remove: removeFile config
    }
  use $ static "dist"

main :: forall e
   . Eff
       ( console :: CONSOLE
       , db :: DBEffects
       , process :: PROCESS
       , cp :: CHILD_PROCESS
       , express :: EXPRESS
       , fs :: FS
       | e
       )
 Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"


Fix markup in Field law

Fix markup in Field law

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/))
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
import Data.Unit (Unit)

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = zero`` for all `a` and `b`
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number
instance fieldUnit :: Field Unit

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/))
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))
import Data.Unit (Unit)

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = 0` for all `a` and `b` ``
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number
instance fieldUnit :: Field Unit


Address review comments

Address review comments

module Data.Unfoldable1
  ( class Unfoldable1, unfoldr1
  , replicate1
  , replicate1A
  , singleton
  , range
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Semigroup.Traversable (class Traversable1, sequence1)
import Data.Tuple (Tuple(..))

-- | This class identifies non-empty data structures which can be _unfolded_.
-- |
-- | The generating function `f` corresponds to the `uncons` operation of a
-- | non-empty list or array; it always return a value, and then optionally
-- | a value to continue unfolding from.
class Unfoldable1 t where
  unfoldr1 :: forall a b. (b -> Tuple a (Maybe b)) -> b -> t a

-- | Replicate a value `n` times. At least one value will be produced, so values
-- | `n < 1` less than one will be ignored.
-- |
-- | ``` purescript
-- | replicate1 0 "foo" == NEL.singleton "foo" :: NEL.NonEmptyList String
-- | replicate1 2 "foo" == NEL.cons "foo" (NEL.singleton "foo") :: NEL.NonEmptyList String
-- | ```
replicate1 :: forall f a. Unfoldable1 f => Int -> a -> f a
replicate1 n v = unfoldr1 step (n - 1)
  where
    step :: Int -> Tuple a (Maybe Int)
    step i
      | i <= 0 = Tuple v Nothing
      | otherwise = Tuple v (Just (i - 1))

-- | Perform an `Applicative` action `n` times (at least once, so values `n < 1`
-- | less than one will be ignored), and accumulate the results.
replicate1A
  :: forall m f a
   . Apply m
  => Unfoldable1 f
  => Traversable1 f
  => Int
  -> m a
  -> m (f a)
replicate1A n m = sequence1 (replicate1 n m)

-- | Contain a single value. For example:
-- |
-- | ``` purescript
-- | singleton "foo" == NEL.singleton "foo" :: NEL.NonEmptyList String
-- | ```
singleton :: forall f a. Unfoldable1 f => a -> f a
singleton = replicate1 1

-- | Create an `Unfoldable1` containing a range of values, including both
-- | endpoints.
-- |
-- | ``` purescript
-- | range 0 0 "foo" == NEL.singleton 0 :: NEL.NonEmptyList Int
-- | range 1 2 "foo" == NEL.cons 1 (NEL.singleton 2) :: NEL.NonEmptyList Int
-- | range 2 0 "foo" == NEL.cons 2 (NEL.cons 1 (NEL.singleton 0)) :: NEL.NonEmptyList Int
-- | ```
range :: forall f. Unfoldable1 f => Int -> Int -> f Int
range start end =
  let delta = if end >= start then 1 else -1 in unfoldr1 (go delta) start
  where
    go delta i =
      let i' = i + delta
      in Tuple i (if i == end then Nothing else Just i')

module Data.Unfoldable1
  ( class Unfoldable1, unfoldr1
  , replicate1
  , replicate1A
  , singleton
  , range
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Traversable (class Traversable, sequence)
import Data.Tuple (Tuple(..))

-- | This class identifies non-empty data structures which can be _unfolded_,
-- | generalizing `unfoldr1` on non-empty lists or arrays.
-- |
-- | The generating function `f` corresponds to the `uncons` operation of a
-- | non-empty list or array; it always return a value, and then optionally
-- | a value to continue unfolding from.
class Unfoldable1 t where
  unfoldr1 :: forall a b. (b -> Tuple a (Maybe b)) -> b -> t a

-- | Replicate a value `n` times. At least one value will be produced, so values
-- | `n < 1` less than one will be ignored.
-- |
-- | ``` purescript
-- | replicate1 0 "foo" == NEL.singleton "foo" :: NEL.NonEmptyList String
-- | replicate1 2 "foo" == NEL.cons "foo" (NEL.singleton "foo") :: NEL.NonEmptyList String
-- | ```
replicate1 :: forall f a. Unfoldable1 f => Int -> a -> f a
replicate1 n v = unfoldr1 step (n - 1)
  where
    step :: Int -> Tuple a (Maybe Int)
    step i
      | i <= 0 = Tuple v Nothing
      | otherwise = Tuple v (Just (i - 1))

-- | Perform an `Applicative` action `n` times (at least once, so values `n < 1`
-- | less than one will be ignored), and accumulate the results.
replicate1A
  :: forall m f a
   . Applicative m
  => Unfoldable1 f
  => Traversable f
  => Int
  -> m a
  -> m (f a)
replicate1A n m = sequence (replicate1 n m)

-- | Contain a single value. For example:
-- |
-- | ``` purescript
-- | singleton "foo" == NEL.singleton "foo" :: NEL.NonEmptyList String
-- | ```
singleton :: forall f a. Unfoldable1 f => a -> f a
singleton = replicate1 1

-- | Create an `Unfoldable1` containing a range of values, including both
-- | endpoints.
-- |
-- | ``` purescript
-- | range 0 0 "foo" == NEL.singleton 0 :: NEL.NonEmptyList Int
-- | range 1 2 "foo" == NEL.cons 1 (NEL.singleton 2) :: NEL.NonEmptyList Int
-- | range 2 0 "foo" == NEL.cons 2 (NEL.cons 1 (NEL.singleton 0)) :: NEL.NonEmptyList Int
-- | ```
range :: forall f. Unfoldable1 f => Int -> Int -> f Int
range start end =
  let delta = if end >= start then 1 else -1 in unfoldr1 (go delta) start
  where
    go delta i =
      let i' = i + delta
      in Tuple i (if i == end then Nothing else Just i')